home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 2003 August / MW 8 2003 CD1.iso / Inside Macworld / Product News / gimp-1.2.4.sit / gimp-1.2.4 / plug-ins / script-fu / interp_sliba.c < prev    next >
Encoding:
C/C++ Source or Header  |  2003-01-15  |  61.1 KB  |  2,918 lines
  1.  
  2.  
  3. /*
  4.  *                   COPYRIGHT (c) 1988-1994 BY                             *
  5.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  6.  *        See the source file SLIB.C for more information.                  *
  7.  
  8.  Array-hacking code moved to another source file.
  9.  
  10.  */
  11.  
  12. #include <stdio.h>
  13. #include <string.h>
  14. #include <setjmp.h>
  15. #include <stdlib.h>
  16. #include <stdarg.h>
  17. #include <ctype.h>
  18. #include <math.h>
  19.  
  20. #include "siod.h"
  21. #include "siodp.h"
  22.  
  23. static void
  24. init_sliba_version (void)
  25. {
  26.   setvar (cintern ("*sliba-version*"),
  27.       cintern ("$Id: interp_sliba.c,v 1.6.2.3 2003/01/15 03:16:53 yosh Exp $"),
  28.       NIL);
  29. }
  30.  
  31. static LISP sym_plists = NIL;
  32. static LISP bashnum = NIL;
  33. static LISP sym_e = NIL;
  34. static LISP sym_f = NIL;
  35.  
  36. void
  37. init_storage_a1 (long type)
  38. {
  39.   long j;
  40.   struct user_type_hooks *p;
  41.   set_gc_hooks (type,
  42.         array_gc_relocate,
  43.         array_gc_mark,
  44.         array_gc_scan,
  45.         array_gc_free,
  46.         &j);
  47.   set_print_hooks (type, array_prin1);
  48.   p = get_user_type_hooks (type);
  49.   p->fast_print = array_fast_print;
  50.   p->fast_read = array_fast_read;
  51.   p->equal = array_equal;
  52.   p->c_sxhash = array_sxhash;
  53. }
  54.  
  55. void
  56. init_storage_a (void)
  57. {
  58.   gc_protect (&bashnum);
  59.   bashnum = newcell (tc_flonum);
  60.   init_storage_a1 (tc_string);
  61.   init_storage_a1 (tc_double_array);
  62.   init_storage_a1 (tc_long_array);
  63.   init_storage_a1 (tc_lisp_array);
  64.   init_storage_a1 (tc_byte_array);
  65. }
  66.  
  67. LISP
  68. array_gc_relocate (LISP ptr)
  69. {
  70.   LISP nw;
  71.   if ((nw = heap) >= heap_end)
  72.     gc_fatal_error ();
  73.   heap = nw + 1;
  74.   memcpy (nw, ptr, sizeof (struct obj));
  75.   return (nw);
  76. }
  77.  
  78. void
  79. array_gc_scan (LISP ptr)
  80. {
  81.   long j;
  82.   if TYPEP
  83.     (ptr, tc_lisp_array)
  84.       for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
  85.       ptr->storage_as.lisp_array.data[j] =
  86.     gc_relocate (ptr->storage_as.lisp_array.data[j]);
  87. }
  88.  
  89. LISP
  90. array_gc_mark (LISP ptr)
  91. {
  92.   long j;
  93.   if TYPEP
  94.     (ptr, tc_lisp_array)
  95.       for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
  96.       gc_mark (ptr->storage_as.lisp_array.data[j]);
  97.   return (NIL);
  98. }
  99.  
  100. void
  101. array_gc_free (LISP ptr)
  102. {
  103.   switch (ptr->type)
  104.     {
  105.     case tc_string:
  106.     case tc_byte_array:
  107.       free (ptr->storage_as.string.data);
  108.       break;
  109.     case tc_double_array:
  110.       free (ptr->storage_as.double_array.data);
  111.       break;
  112.     case tc_long_array:
  113.       free (ptr->storage_as.long_array.data);
  114.       break;
  115.     case tc_lisp_array:
  116.       free (ptr->storage_as.lisp_array.data);
  117.       break;
  118.     }
  119. }
  120.  
  121. void
  122. array_prin1 (LISP ptr, struct gen_printio *f)
  123. {
  124.   int j;
  125.   switch (ptr->type)
  126.     {
  127.     case tc_string:
  128.       gput_st (f, "\"");
  129.       if (strcspn (ptr->storage_as.string.data, "\"\\\n\r\t") ==
  130.       strlen (ptr->storage_as.string.data))
  131.     gput_st (f, ptr->storage_as.string.data);
  132.       else
  133.     {
  134.       int n, c;
  135.       char cbuff[3];
  136.       n = strlen (ptr->storage_as.string.data);
  137.       for (j = 0; j < n; ++j)
  138.         switch (c = ptr->storage_as.string.data[j])
  139.           {
  140.           case '\\':
  141.           case '"':
  142.         cbuff[0] = '\\';
  143.         cbuff[1] = c;
  144.         cbuff[2] = 0;
  145.         gput_st (f, cbuff);
  146.         break;
  147.           case '\n':
  148.         gput_st (f, "\\n");
  149.         break;
  150.           case '\r':
  151.         gput_st (f, "\\r");
  152.         break;
  153.           case '\t':
  154.         gput_st (f, "\\t");
  155.         break;
  156.           default:
  157.         cbuff[0] = c;
  158.         cbuff[1] = 0;
  159.         gput_st (f, cbuff);
  160.         break;
  161.           }
  162.     }
  163.       gput_st (f, "\"");
  164.       break;
  165.     case tc_double_array:
  166.       gput_st (f, "#(");
  167.       for (j = 0; j < ptr->storage_as.double_array.dim; ++j)
  168.     {
  169.       sprintf (tkbuffer, "%g", ptr->storage_as.double_array.data[j]);
  170.       gput_st (f, tkbuffer);
  171.       if ((j + 1) < ptr->storage_as.double_array.dim)
  172.         gput_st (f, " ");
  173.     }
  174.       gput_st (f, ")");
  175.       break;
  176.     case tc_long_array:
  177.       gput_st (f, "#(");
  178.       for (j = 0; j < ptr->storage_as.long_array.dim; ++j)
  179.     {
  180.       sprintf (tkbuffer, "%ld", ptr->storage_as.long_array.data[j]);
  181.       gput_st (f, tkbuffer);
  182.       if ((j + 1) < ptr->storage_as.long_array.dim)
  183.         gput_st (f, " ");
  184.     }
  185.       gput_st (f, ")");
  186.     case tc_byte_array:
  187.       sprintf (tkbuffer, "#%ld\"", ptr->storage_as.string.dim);
  188.       gput_st (f, tkbuffer);
  189.       for (j = 0; j < ptr->storage_as.string.dim; ++j)
  190.     {
  191.       sprintf (tkbuffer, "%02x", ptr->storage_as.string.data[j] & 0xFF);
  192.       gput_st (f, tkbuffer);
  193.     }
  194.       gput_st (f, "\"");
  195.       break;
  196.     case tc_lisp_array:
  197.       gput_st (f, "#(");
  198.       for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
  199.     {
  200.       lprin1g (ptr->storage_as.lisp_array.data[j], f);
  201.       if ((j + 1) < ptr->storage_as.lisp_array.dim)
  202.         gput_st (f, " ");
  203.     }
  204.       gput_st (f, ")");
  205.       break;
  206.     }
  207. }
  208.  
  209. LISP
  210. strcons (long length, char *data)
  211. {
  212.   long flag;
  213.   LISP s;
  214.   flag = no_interrupt (1);
  215.   s = cons (NIL, NIL);
  216.   s->type = tc_string;
  217.   if (length == -1)
  218.     length = strlen (data);
  219.   s->storage_as.string.data = must_malloc (length + 1);
  220.   s->storage_as.string.dim = length;
  221.   if (data)
  222.     memcpy (s->storage_as.string.data, data, length);
  223.   s->storage_as.string.data[length] = 0;
  224.   no_interrupt (flag);
  225.   return (s);
  226. }
  227.  
  228. int
  229. rfs_getc (unsigned char **p)
  230. {
  231.   int i;
  232.   i = **p;
  233.   if (!i)
  234.     return (EOF);
  235.   *p = *p + 1;
  236.   return (i);
  237. }
  238.  
  239. void
  240. rfs_ungetc (unsigned char c, unsigned char **p)
  241. {
  242.   *p = *p - 1;
  243. }
  244.  
  245. LISP
  246. read_from_string (LISP x)
  247. {
  248.   char *p;
  249.   struct gen_readio s;
  250.   p = get_c_string (x);
  251.   s.getc_fcn = (int (*)(void *)) rfs_getc;
  252.   s.ungetc_fcn = (void (*)(int, void *)) rfs_ungetc;
  253.   s.cb_argument = (char *) &p;
  254.   return (readtl (&s));
  255. }
  256.  
  257. int
  258. pts_puts (char *from, void *cb)
  259. {
  260.   LISP into;
  261.   size_t fromlen, intolen, intosize, fitsize;
  262.   into = (LISP) cb;
  263.   fromlen = strlen (from);
  264.   intolen = strlen (into->storage_as.string.data);
  265.   intosize = into->storage_as.string.dim - intolen;
  266.   fitsize = (fromlen < intosize) ? fromlen : intosize;
  267.   memcpy (&into->storage_as.string.data[intolen], from, fitsize);
  268.   into->storage_as.string.data[intolen + fitsize] = 0;
  269.   if (fitsize < fromlen)
  270.     my_err ("print to string overflow", NIL);
  271.   return (1);
  272. }
  273.  
  274. LISP
  275. err_wta_str (LISP exp)
  276. {
  277.   return (my_err ("not a string", exp));
  278. }
  279.  
  280. LISP
  281. print_to_string (LISP exp, LISP str, LISP nostart)
  282. {
  283.   struct gen_printio s;
  284.   if NTYPEP
  285.     (str, tc_string) err_wta_str (str);
  286.   s.putc_fcn = NULL;
  287.   s.puts_fcn = pts_puts;
  288.   s.cb_argument = str;
  289.   if NULLP
  290.     (nostart)
  291.       str->storage_as.string.data[0] = 0;
  292.   lprin1g (exp, &s);
  293.   return (str);
  294. }
  295.  
  296. LISP
  297. aref1 (LISP a, LISP i)
  298. {
  299.   long k;
  300.   if NFLONUMP
  301.     (i) my_err ("bad index to aref", i);
  302.   k = (long) FLONM (i);
  303.   if (k < 0)
  304.     my_err ("negative index to aref", i);
  305.   switch TYPE
  306.     (a)
  307.     {
  308.     case tc_string:
  309.     case tc_byte_array:
  310.       if (k >= a->storage_as.string.dim)
  311.     my_err ("index too large", i);
  312.       return (flocons ((double) a->storage_as.string.data[k]));
  313.     case tc_double_array:
  314.       if (k >= a->storage_as.double_array.dim)
  315.     my_err ("index too large", i);
  316.       return (flocons (a->storage_as.double_array.data[k]));
  317.     case tc_long_array:
  318.       if (k >= a->storage_as.long_array.dim)
  319.     my_err ("index too large", i);
  320.       return (flocons (a->storage_as.long_array.data[k]));
  321.     case tc_lisp_array:
  322.       if (k >= a->storage_as.lisp_array.dim)
  323.     my_err ("index too large", i);
  324.       return (a->storage_as.lisp_array.data[k]);
  325.     default:
  326.       return (my_err ("invalid argument to aref", a));
  327.     }
  328. }
  329.  
  330. void
  331. err1_aset1 (LISP i)
  332. {
  333.   my_err ("index to aset too large", i);
  334. }
  335.  
  336. void
  337. err2_aset1 (LISP v)
  338. {
  339.   my_err ("bad value to store in array", v);
  340. }
  341.  
  342. LISP
  343. aset1 (LISP a, LISP i, LISP v)
  344. {
  345.   long k;
  346.   if NFLONUMP
  347.     (i) my_err ("bad index to aset", i);
  348.   k = (long) FLONM (i);
  349.   if (k < 0)
  350.     my_err ("negative index to aset", i);
  351.   switch TYPE
  352.     (a)
  353.     {
  354.     case tc_string:
  355.     case tc_byte_array:
  356.       if NFLONUMP
  357.     (v) err2_aset1 (v);
  358.       if (k >= a->storage_as.string.dim)
  359.     err1_aset1 (i);
  360.       a->storage_as.string.data[k] = (char) FLONM (v);
  361.       return (v);
  362.     case tc_double_array:
  363.       if NFLONUMP
  364.     (v) err2_aset1 (v);
  365.       if (k >= a->storage_as.double_array.dim)
  366.     err1_aset1 (i);
  367.       a->storage_as.double_array.data[k] = FLONM (v);
  368.       return (v);
  369.     case tc_long_array:
  370.       if NFLONUMP
  371.     (v) err2_aset1 (v);
  372.       if (k >= a->storage_as.long_array.dim)
  373.     err1_aset1 (i);
  374.       a->storage_as.long_array.data[k] = (long) FLONM (v);
  375.       return (v);
  376.     case tc_lisp_array:
  377.       if (k >= a->storage_as.lisp_array.dim)
  378.     err1_aset1 (i);
  379.       a->storage_as.lisp_array.data[k] = v;
  380.       return (v);
  381.     default:
  382.       return (my_err ("invalid argument to aset", a));
  383.     }
  384. }
  385.  
  386. LISP
  387. arcons (long typecode, long n, long initp)
  388. {
  389.   LISP a;
  390.   long flag, j;
  391.   flag = no_interrupt (1);
  392.   a = cons (NIL, NIL);
  393.   switch (typecode)
  394.     {
  395.     case tc_double_array:
  396.       a->storage_as.double_array.dim = n;
  397.       a->storage_as.double_array.data = (double *) must_malloc (n *
  398.                                sizeof (double));
  399.       if (initp)
  400.     for (j = 0; j < n; ++j)
  401.       a->storage_as.double_array.data[j] = 0.0;
  402.       break;
  403.     case tc_long_array:
  404.       a->storage_as.long_array.dim = n;
  405.       a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
  406.       if (initp)
  407.     for (j = 0; j < n; ++j)
  408.       a->storage_as.long_array.data[j] = 0;
  409.       break;
  410.     case tc_string:
  411.       a->storage_as.string.dim = n;
  412.       a->storage_as.string.data = (char *) must_malloc (n + 1);
  413.       a->storage_as.string.data[n] = 0;
  414.       if (initp)
  415.     for (j = 0; j < n; ++j)
  416.       a->storage_as.string.data[j] = ' ';
  417.     case tc_byte_array:
  418.       a->storage_as.string.dim = n;
  419.       a->storage_as.string.data = (char *) must_malloc (n);
  420.       if (initp)
  421.     for (j = 0; j < n; ++j)
  422.       a->storage_as.string.data[j] = 0;
  423.       break;
  424.     case tc_lisp_array:
  425.       a->storage_as.lisp_array.dim = n;
  426.       a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
  427.       for (j = 0; j < n; ++j)
  428.     a->storage_as.lisp_array.data[j] = NIL;
  429.       break;
  430.     default:
  431.       errswitch ();
  432.     }
  433.   a->type = typecode;
  434.   no_interrupt (flag);
  435.   return (a);
  436. }
  437.  
  438. LISP
  439. mallocl (void *place, long size)
  440. {
  441.   long n, r;
  442.   LISP retval;
  443.   n = size / sizeof (long);
  444.   r = size % sizeof (long);
  445.   if (r)
  446.     ++n;
  447.   retval = arcons (tc_long_array, n, 0);
  448.   *(long **) place = retval->storage_as.long_array.data;
  449.   return (retval);
  450. }
  451.  
  452. LISP
  453. cons_array (LISP dim, LISP kind)
  454. {
  455.   LISP a;
  456.   long flag, n, j;
  457.   if (NFLONUMP (dim) || (FLONM (dim) < 0))
  458.     return (my_err ("bad dimension to cons-array", dim));
  459.   else
  460.     n = (long) FLONM (dim);
  461.   flag = no_interrupt (1);
  462.   a = cons (NIL, NIL);
  463.   if EQ
  464.     (cintern ("double"), kind)
  465.     {
  466.       a->type = tc_double_array;
  467.       a->storage_as.double_array.dim = n;
  468.       a->storage_as.double_array.data = (double *) must_malloc (n *
  469.                                sizeof (double));
  470.       for (j = 0; j < n; ++j)
  471.     a->storage_as.double_array.data[j] = 0.0;
  472.     }
  473.   else if EQ
  474.     (cintern ("long"), kind)
  475.     {
  476.       a->type = tc_long_array;
  477.       a->storage_as.long_array.dim = n;
  478.       a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
  479.       for (j = 0; j < n; ++j)
  480.     a->storage_as.long_array.data[j] = 0;
  481.     }
  482.   else if EQ
  483.     (cintern ("string"), kind)
  484.     {
  485.       a->type = tc_string;
  486.       a->storage_as.string.dim = n;
  487.       a->storage_as.string.data = (char *) must_malloc (n + 1);
  488.       a->storage_as.string.data[n] = 0;
  489.       for (j = 0; j < n; ++j)
  490.     a->storage_as.string.data[j] = ' ';
  491.     }
  492.   else if EQ
  493.     (cintern ("byte"), kind)
  494.     {
  495.       a->type = tc_byte_array;
  496.       a->storage_as.string.dim = n;
  497.       a->storage_as.string.data = (char *) must_malloc (n);
  498.       for (j = 0; j < n; ++j)
  499.     a->storage_as.string.data[j] = 0;
  500.     }
  501.   else if (EQ (cintern ("lisp"), kind) || NULLP (kind))
  502.     {
  503.       a->type = tc_lisp_array;
  504.       a->storage_as.lisp_array.dim = n;
  505.       a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
  506.       for (j = 0; j < n; ++j)
  507.     a->storage_as.lisp_array.data[j] = NIL;
  508.     }
  509.   else
  510.     my_err ("bad type of array", kind);
  511.   no_interrupt (flag);
  512.   return (a);
  513. }
  514.  
  515. LISP
  516. string_append (LISP args)
  517. {
  518.   long size;
  519.   LISP l, s;
  520.   char *data;
  521.   size = 0;
  522.   for (l = args; NNULLP (l); l = cdr (l))
  523.     size += strlen (get_c_string (car (l)));
  524.   s = strcons (size, NULL);
  525.   data = s->storage_as.string.data;
  526.   data[0] = 0;
  527.   for (l = args; NNULLP (l); l = cdr (l))
  528.     strcat (data, get_c_string (car (l)));
  529.   return (s);
  530. }
  531.  
  532. LISP
  533. bytes_append (LISP args)
  534. {
  535.   long size, n, j;
  536.   LISP l, s;
  537.   char *data, *ptr;
  538.   size = 0;
  539.   for (l = args; NNULLP (l); l = cdr (l))
  540.     {
  541.       get_c_string_dim (car (l), &n);
  542.       size += n;
  543.     }
  544.   s = arcons (tc_byte_array, size, 0);
  545.   data = s->storage_as.string.data;
  546.   for (j = 0, l = args; NNULLP (l); l = cdr (l))
  547.     {
  548.       ptr = get_c_string_dim (car (l), &n);
  549.       memcpy (&data[j], ptr, n);
  550.       j += n;
  551.     }
  552.   return (s);
  553. }
  554.  
  555. LISP
  556. substring (LISP str, LISP start, LISP end)
  557. {
  558.   long s, e, n;
  559.   char *data;
  560.   data = get_c_string_dim (str, &n);
  561.   s = get_c_long (start);
  562.   if NULLP
  563.     (end)
  564.       e = n;
  565.   else
  566.     e = get_c_long (end);
  567.   if ((s < 0) || (s > e))
  568.     my_err ("bad start index", start);
  569.   if ((e < 0) || (e > n))
  570.     my_err ("bad end index", end);
  571.   return (strcons (e - s, &data[s]));
  572. }
  573.  
  574. LISP
  575. string_search (LISP token, LISP str)
  576. {
  577.   char *s1, *s2, *ptr;
  578.   s1 = get_c_string (str);
  579.   s2 = get_c_string (token);
  580.   ptr = strstr (s1, s2);
  581.   if (ptr)
  582.     return (flocons (ptr - s1));
  583.   else
  584.     return (NIL);
  585. }
  586.  
  587. #define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x)))
  588.  
  589. LISP
  590. string_trim (LISP str)
  591. {
  592.   char *start, *end; /*, *sp = " \t\r\n";*/
  593.   start = get_c_string (str);
  594.   while (*start && IS_TRIM_SPACE (*start))
  595.     ++start;
  596.   end = &start[strlen (start)];
  597.   while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
  598.     --end;
  599.   return (strcons (end - start, start));
  600. }
  601.  
  602. LISP
  603. string_trim_left (LISP str)
  604. {
  605.   char *start, *end;
  606.   start = get_c_string (str);
  607.   while (*start && IS_TRIM_SPACE (*start))
  608.     ++start;
  609.   end = &start[strlen (start)];
  610.   return (strcons (end - start, start));
  611. }
  612.  
  613. LISP
  614. string_trim_right (LISP str)
  615. {
  616.   char *start, *end;
  617.   start = get_c_string (str);
  618.   end = &start[strlen (start)];
  619.   while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
  620.     --end;
  621.   return (strcons (end - start, start));
  622. }
  623.  
  624. LISP
  625. string_upcase (LISP str)
  626. {
  627.   LISP result;
  628.   char *s1, *s2;
  629.   long j, n;
  630.   s1 = get_c_string (str);
  631.   n = strlen (s1);
  632.   result = strcons (n, s1);
  633.   s2 = get_c_string (result);
  634.   for (j = 0; j < n; ++j)
  635.     s2[j] = toupper (s2[j]);
  636.   return (result);
  637. }
  638.  
  639. LISP
  640. string_downcase (LISP str)
  641. {
  642.   LISP result;
  643.   char *s1, *s2;
  644.   long j, n;
  645.   s1 = get_c_string (str);
  646.   n = strlen (s1);
  647.   result = strcons (n, s1);
  648.   s2 = get_c_string (result);
  649.   for (j = 0; j < n; ++j)
  650.     s2[j] = tolower (s2[j]);
  651.   return (result);
  652. }
  653.  
  654. LISP
  655. lreadstring (struct gen_readio * f)
  656. {
  657.   int j, c, n, ndigits;
  658.   char *p;
  659.   j = 0;
  660.   p = tkbuffer;
  661.   while (((c = GETC_FCN (f)) != '"') && (c != EOF))
  662.     {
  663.       if (c == '\\')
  664.     {
  665.       c = GETC_FCN (f);
  666.       if (c == EOF)
  667.         my_err ("eof after \\", NIL);
  668.       switch (c)
  669.         {
  670.         case '\\':
  671.           c = '\\';
  672.           break;
  673.         case 'n':
  674.           c = '\n';
  675.           break;
  676.         case 't':
  677.           c = '\t';
  678.           break;
  679.         case 'r':
  680.           c = '\r';
  681.           break;
  682.         case 'd':
  683.           c = 0x04;
  684.           break;
  685.         case 'N':
  686.           c = 0;
  687.           break;
  688.         case 's':
  689.           c = ' ';
  690.           break;
  691.         case '0':
  692.         case '1':
  693.         case '2':
  694.         case '3':
  695.         case '4':
  696.         case '5':
  697.         case '6':
  698.         case '7':
  699.           n = c - '0';
  700.           ndigits = 1;
  701.           while (ndigits < 3)
  702.         {
  703.           c = GETC_FCN (f);
  704.           if (c == EOF)
  705.             my_err ("eof after \\0", NIL);
  706.           if (c >= '0' && c <= '7')
  707.             {
  708.               n = n * 8 + c - '0';
  709.               ndigits++;
  710.             }
  711.           else
  712.             {
  713.               UNGETC_FCN (c, f);
  714.               break;
  715.             }
  716.         }
  717.           c = n;
  718.         }
  719.     }
  720.       if ((j + 1) >= TKBUFFERN)
  721.     my_err ("read string overflow", NIL);
  722.       ++j;
  723.       *p++ = c;
  724.     }
  725.   *p = 0;
  726.   return (strcons (j, tkbuffer));
  727. }
  728.  
  729.  
  730. LISP
  731. lreadsharp (struct gen_readio * f)
  732. {
  733.   LISP obj, l, result;
  734.   long j, n;
  735.   int c;
  736.   c = GETC_FCN (f);
  737.   switch (c)
  738.     {
  739.     case '(':
  740.       UNGETC_FCN (c, f);
  741.       obj = lreadr (f);
  742.       n = nlength (obj);
  743.       result = arcons (tc_lisp_array, n, 1);
  744.       for (l = obj, j = 0; j < n; l = cdr (l), ++j)
  745.     result->storage_as.lisp_array.data[j] = car (l);
  746.       return (result);
  747.     case '.':
  748.       obj = lreadr (f);
  749.       return (leval (obj, NIL));
  750.     case 'f':
  751.       return (NIL);
  752.     case 't':
  753.       return (flocons (1));
  754.     default:
  755.       return (my_err ("readsharp syntax not handled", NIL));
  756.     }
  757. }
  758.  
  759. #define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
  760.  
  761. long
  762. c_sxhash (LISP obj, long n)
  763. {
  764.   long hash;
  765.   unsigned char *s;
  766.   LISP tmp;
  767.   struct user_type_hooks *p;
  768.   STACK_CHECK (&obj);
  769.   INTERRUPT_CHECK ();
  770.   switch TYPE
  771.     (obj)
  772.     {
  773.     case tc_nil:
  774.       return (0);
  775.     case tc_cons:
  776.       hash = c_sxhash (CAR (obj), n);
  777.       for (tmp = CDR (obj); CONSP (tmp); tmp = CDR (tmp))
  778.     hash = HASH_COMBINE (hash, c_sxhash (CAR (tmp), n), n);
  779.       hash = HASH_COMBINE (hash, c_sxhash (tmp, n), n);
  780.       return (hash);
  781.     case tc_symbol:
  782.       for (hash = 0, s = (unsigned char *) PNAME (obj); *s; ++s)
  783.     hash = HASH_COMBINE (hash, *s, n);
  784.       return (hash);
  785.     case tc_subr_0:
  786.     case tc_subr_1:
  787.     case tc_subr_2:
  788.     case tc_subr_3:
  789.     case tc_subr_4:
  790.     case tc_subr_5:
  791.     case tc_lsubr:
  792.     case tc_fsubr:
  793.     case tc_msubr:
  794.       for (hash = 0, s = (unsigned char *) obj->storage_as.subr.name; *s; ++s)
  795.     hash = HASH_COMBINE (hash, *s, n);
  796.       return (hash);
  797.     case tc_flonum:
  798.       return (((unsigned long) FLONM (obj)) % n);
  799.     default:
  800.       p = get_user_type_hooks (TYPE (obj));
  801.       if (p->c_sxhash)
  802.     return ((*p->c_sxhash) (obj, n));
  803.       else
  804.     return (0);
  805.     }
  806. }
  807.  
  808. LISP
  809. sxhash (LISP obj, LISP n)
  810. {
  811.   return (flocons (c_sxhash (obj, FLONUMP (n) ? (long) FLONM (n) : 10000)));
  812. }
  813.  
  814. LISP
  815. equal (LISP a, LISP b)
  816. {
  817.   struct user_type_hooks *p;
  818.   long atype;
  819.   STACK_CHECK (&a);
  820. loop:
  821.   INTERRUPT_CHECK ();
  822.   if EQ
  823.     (a, b) return (sym_t);
  824.   atype = TYPE (a);
  825.   if (atype != TYPE (b))
  826.     return (NIL);
  827.   switch (atype)
  828.     {
  829.     case tc_cons:
  830.       if NULLP
  831.     (equal (car (a), car (b))) return (NIL);
  832.       a = cdr (a);
  833.       b = cdr (b);
  834.       goto loop;
  835.     case tc_flonum:
  836.       return ((FLONM (a) == FLONM (b)) ? sym_t : NIL);
  837.     case tc_symbol:
  838.       return (NIL);
  839.     default:
  840.       p = get_user_type_hooks (atype);
  841.       if (p->equal)
  842.     return ((*p->equal) (a, b));
  843.       else
  844.     return (NIL);
  845.     }
  846. }
  847.  
  848. LISP
  849. array_equal (LISP a, LISP b)
  850. {
  851.   long j, len;
  852.   switch (TYPE (a))
  853.     {
  854.     case tc_string:
  855.     case tc_byte_array:
  856.       len = a->storage_as.string.dim;
  857.       if (len != b->storage_as.string.dim)
  858.     return (NIL);
  859.       if (memcmp (a->storage_as.string.data, b->storage_as.string.data, len) == 0)
  860.     return (sym_t);
  861.       else
  862.     return (NIL);
  863.     case tc_long_array:
  864.       len = a->storage_as.long_array.dim;
  865.       if (len != b->storage_as.long_array.dim)
  866.     return (NIL);
  867.       if (memcmp (a->storage_as.long_array.data,
  868.           b->storage_as.long_array.data,
  869.           len * sizeof (long)) == 0)
  870.       return (sym_t);
  871.       else
  872.     return (NIL);
  873.     case tc_double_array:
  874.       len = a->storage_as.double_array.dim;
  875.       if (len != b->storage_as.double_array.dim)
  876.     return (NIL);
  877.       for (j = 0; j < len; ++j)
  878.     if (a->storage_as.double_array.data[j] !=
  879.         b->storage_as.double_array.data[j])
  880.       return (NIL);
  881.       return (sym_t);
  882.     case tc_lisp_array:
  883.       len = a->storage_as.lisp_array.dim;
  884.       if (len != b->storage_as.lisp_array.dim)
  885.     return (NIL);
  886.       for (j = 0; j < len; ++j)
  887.     if NULLP
  888.       (equal (a->storage_as.lisp_array.data[j],
  889.           b->storage_as.lisp_array.data[j]))
  890.         return (NIL);
  891.       return (sym_t);
  892.     default:
  893.       return (errswitch ());
  894.     }
  895. }
  896.  
  897. long
  898. array_sxhash (LISP a, long n)
  899. {
  900.   long j, len, hash;
  901.   unsigned char *char_data;
  902.   unsigned long *long_data;
  903.   double *double_data;
  904.   switch (TYPE (a))
  905.     {
  906.     case tc_string:
  907.     case tc_byte_array:
  908.       len = a->storage_as.string.dim;
  909.       for (j = 0, hash = 0, char_data = (unsigned char *) a->storage_as.string.data;
  910.        j < len;
  911.        ++j, ++char_data)
  912.     hash = HASH_COMBINE (hash, *char_data, n);
  913.       return (hash);
  914.     case tc_long_array:
  915.       len = a->storage_as.long_array.dim;
  916.       for (j = 0, hash = 0, long_data = (unsigned long *) a->storage_as.long_array.data;
  917.        j < len;
  918.        ++j, ++long_data)
  919.     hash = HASH_COMBINE (hash, *long_data % n, n);
  920.       return (hash);
  921.     case tc_double_array:
  922.       len = a->storage_as.double_array.dim;
  923.       for (j = 0, hash = 0, double_data = a->storage_as.double_array.data;
  924.        j < len;
  925.        ++j, ++double_data)
  926.     hash = HASH_COMBINE (hash, (unsigned long) *double_data % n, n);
  927.       return (hash);
  928.     case tc_lisp_array:
  929.       len = a->storage_as.lisp_array.dim;
  930.       for (j = 0, hash = 0; j < len; ++j)
  931.     hash = HASH_COMBINE (hash,
  932.                  c_sxhash (a->storage_as.lisp_array.data[j], n),
  933.                  n);
  934.       return (hash);
  935.     default:
  936.       errswitch ();
  937.       return (0);
  938.     }
  939. }
  940.  
  941. long
  942. href_index (LISP table, LISP key)
  943. {
  944.   long index;
  945.   if NTYPEP
  946.     (table, tc_lisp_array) my_err ("not a hash table", table);
  947.   index = c_sxhash (key, table->storage_as.lisp_array.dim);
  948.   if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
  949.     {
  950.       my_err ("sxhash inconsistency", table);
  951.       return (0);
  952.     }
  953.   else
  954.     return (index);
  955. }
  956.  
  957. LISP
  958. href (LISP table, LISP key)
  959. {
  960.   return (cdr (assoc (key,
  961.           table->storage_as.lisp_array.data[href_index (table, key)])));
  962. }
  963.  
  964. LISP
  965. hset (LISP table, LISP key, LISP value)
  966. {
  967.   long index;
  968.   LISP cell, l;
  969.   index = href_index (table, key);
  970.   l = table->storage_as.lisp_array.data[index];
  971.   if NNULLP
  972.     (cell = assoc (key, l))
  973.       return (setcdr (cell, value));
  974.   cell = cons (key, value);
  975.   table->storage_as.lisp_array.data[index] = cons (cell, l);
  976.   return (value);
  977. }
  978.  
  979. LISP
  980. assoc (LISP x, LISP alist)
  981. {
  982.   LISP l, tmp;
  983.   for (l = alist; CONSP (l); l = CDR (l))
  984.     {
  985.       tmp = CAR (l);
  986.       if (CONSP (tmp) && equal (CAR (tmp), x))
  987.     return (tmp);
  988.       INTERRUPT_CHECK ();
  989.     }
  990.   if EQ
  991.     (l, NIL) return (NIL);
  992.   return (my_err ("improper list to assoc", alist));
  993. }
  994.  
  995. LISP
  996. assv (LISP x, LISP alist)
  997. {
  998.   LISP l, tmp;
  999.   for (l = alist; CONSP (l); l = CDR (l))
  1000.     {
  1001.       tmp = CAR (l);
  1002.       if (CONSP (tmp) && NNULLP (eql (CAR (tmp), x)))
  1003.     return (tmp);
  1004.       INTERRUPT_CHECK ();
  1005.     }
  1006.   if EQ
  1007.     (l, NIL) return (NIL);
  1008.   return (my_err ("improper list to assv", alist));
  1009. }
  1010.  
  1011. void
  1012. put_long (long i, FILE * f)
  1013. {
  1014.   fwrite (&i, sizeof (long), 1, f);
  1015. }
  1016.  
  1017. long
  1018. get_long (FILE * f)
  1019. {
  1020.   long i;
  1021.   fread (&i, sizeof (long), 1, f);
  1022.   return (i);
  1023. }
  1024.  
  1025. long
  1026. fast_print_table (LISP obj, LISP table)
  1027. {
  1028.   FILE *f;
  1029.   LISP ht, index;
  1030.   f = get_c_file (car (table), (FILE *) NULL);
  1031.   if NULLP
  1032.     (ht = car (cdr (table)))
  1033.       return (1);
  1034.   index = href (ht, obj);
  1035.   if NNULLP
  1036.     (index)
  1037.     {
  1038.       putc (FO_fetch, f);
  1039.       put_long (get_c_long (index), f);
  1040.       return (0);
  1041.     }
  1042.   if NULLP
  1043.     (index = car (cdr (cdr (table))))
  1044.       return (1);
  1045.   hset (ht, obj, index);
  1046.   FLONM (bashnum) = 1.0;
  1047.   setcar (cdr (cdr (table)), plus (index, bashnum));
  1048.   putc (FO_store, f);
  1049.   put_long (get_c_long (index), f);
  1050.   return (1);
  1051. }
  1052.  
  1053. LISP
  1054. fast_print (LISP obj, LISP table)
  1055. {
  1056.   FILE *f;
  1057.   long len;
  1058.   LISP tmp;
  1059.   struct user_type_hooks *p;
  1060.   STACK_CHECK (&obj);
  1061.   f = get_c_file (car (table), (FILE *) NULL);
  1062.   switch (TYPE (obj))
  1063.     {
  1064.     case tc_nil:
  1065.       putc (tc_nil, f);
  1066.       return (NIL);
  1067.     case tc_cons:
  1068.       for (len = 0, tmp = obj; CONSP (tmp); tmp = CDR (tmp))
  1069.     {
  1070.       INTERRUPT_CHECK ();
  1071.       ++len;
  1072.     }
  1073.       if (len == 1)
  1074.     {
  1075.       putc (tc_cons, f);
  1076.       fast_print (car (obj), table);
  1077.       fast_print (cdr (obj), table);
  1078.     }
  1079.       else if NULLP
  1080.     (tmp)
  1081.     {
  1082.       putc (FO_list, f);
  1083.       put_long (len, f);
  1084.       for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
  1085.         fast_print (CAR (tmp), table);
  1086.     }
  1087.       else
  1088.     {
  1089.       putc (FO_listd, f);
  1090.       put_long (len, f);
  1091.       for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
  1092.         fast_print (CAR (tmp), table);
  1093.       fast_print (tmp, table);
  1094.     }
  1095.       return (NIL);
  1096.     case tc_flonum:
  1097.       putc (tc_flonum, f);
  1098.       fwrite (&obj->storage_as.flonum.data,
  1099.           sizeof (obj->storage_as.flonum.data),
  1100.           1,
  1101.           f);
  1102.       return (NIL);
  1103.     case tc_symbol:
  1104.       if (fast_print_table (obj, table))
  1105.     {
  1106.       putc (tc_symbol, f);
  1107.       len = strlen (PNAME (obj));
  1108.       if (len >= TKBUFFERN)
  1109.         my_err ("symbol name too long", obj);
  1110.       put_long (len, f);
  1111.       fwrite (PNAME (obj), len, 1, f);
  1112.       return (sym_t);
  1113.     }
  1114.       else
  1115.     return (NIL);
  1116.     default:
  1117.       p = get_user_type_hooks (TYPE (obj));
  1118.       if (p->fast_print)
  1119.     return ((*p->fast_print) (obj, table));
  1120.       else
  1121.     return (my_err ("cannot fast-print", obj));
  1122.     }
  1123. }
  1124.  
  1125. LISP
  1126. fast_read (LISP table)
  1127. {
  1128.   FILE *f;
  1129.   LISP tmp, l;
  1130.   struct user_type_hooks *p;
  1131.   int c;
  1132.   long len;
  1133.   f = get_c_file (car (table), (FILE *) NULL);
  1134.   c = getc (f);
  1135.   if (c == EOF)
  1136.     return (table);
  1137.   switch (c)
  1138.     {
  1139.     case FO_comment:
  1140.       while ((c = getc (f)))
  1141.     switch (c)
  1142.       {
  1143.       case EOF:
  1144.         return (table);
  1145.       case '\n':
  1146.         return (fast_read (table));
  1147.       }
  1148.     case FO_fetch:
  1149.       len = get_long (f);
  1150.       FLONM (bashnum) = len;
  1151.       return (href (car (cdr (table)), bashnum));
  1152.     case FO_store:
  1153.       len = get_long (f);
  1154.       tmp = fast_read (table);
  1155.       hset (car (cdr (table)), flocons (len), tmp);
  1156.       return (tmp);
  1157.     case tc_nil:
  1158.       return (NIL);
  1159.     case tc_cons:
  1160.       tmp = fast_read (table);
  1161.       return (cons (tmp, fast_read (table)));
  1162.     case FO_list:
  1163.     case FO_listd:
  1164.       len = get_long (f);
  1165.       FLONM (bashnum) = len;
  1166.       l = make_list (bashnum, NIL);
  1167.       tmp = l;
  1168.       while (len > 1)
  1169.     {
  1170.       CAR (tmp) = fast_read (table);
  1171.       tmp = CDR (tmp);
  1172.       --len;
  1173.     }
  1174.       CAR (tmp) = fast_read (table);
  1175.       if (c == FO_listd)
  1176.     CDR (tmp) = fast_read (table);
  1177.       return (l);
  1178.     case tc_flonum:
  1179.       tmp = newcell (tc_flonum);
  1180.       fread (&tmp->storage_as.flonum.data,
  1181.          sizeof (tmp->storage_as.flonum.data),
  1182.          1,
  1183.          f);
  1184.       return (tmp);
  1185.     case tc_symbol:
  1186.       len = get_long (f);
  1187.       if (len >= TKBUFFERN)
  1188.     my_err ("symbol name too long", NIL);
  1189.       fread (tkbuffer, len, 1, f);
  1190.       tkbuffer[len] = 0;
  1191.       return (rintern (tkbuffer));
  1192.     default:
  1193.       p = get_user_type_hooks (c);
  1194.       if (p->fast_read)
  1195.     return (*p->fast_read) (c, table);
  1196.       else
  1197.     return (my_err ("unknown fast-read opcode", flocons (c)));
  1198.     }
  1199. }
  1200.  
  1201. LISP
  1202. array_fast_print (LISP ptr, LISP table)
  1203. {
  1204.   int j, len;
  1205.   FILE *f;
  1206.   f = get_c_file (car (table), (FILE *) NULL);
  1207.   switch (ptr->type)
  1208.     {
  1209.     case tc_string:
  1210.     case tc_byte_array:
  1211.       putc (ptr->type, f);
  1212.       len = ptr->storage_as.string.dim;
  1213.       put_long (len, f);
  1214.       fwrite (ptr->storage_as.string.data, len, 1, f);
  1215.       return (NIL);
  1216.     case tc_double_array:
  1217.       putc (tc_double_array, f);
  1218.       len = ptr->storage_as.double_array.dim * sizeof (double);
  1219.       put_long (len, f);
  1220.       fwrite (ptr->storage_as.double_array.data, len, 1, f);
  1221.       return (NIL);
  1222.     case tc_long_array:
  1223.       putc (tc_long_array, f);
  1224.       len = ptr->storage_as.long_array.dim * sizeof (long);
  1225.       put_long (len, f);
  1226.       fwrite (ptr->storage_as.long_array.data, len, 1, f);
  1227.       return (NIL);
  1228.     case tc_lisp_array:
  1229.       putc (tc_lisp_array, f);
  1230.       len = ptr->storage_as.lisp_array.dim;
  1231.       put_long (len, f);
  1232.       for (j = 0; j < len; ++j)
  1233.     fast_print (ptr->storage_as.lisp_array.data[j], table);
  1234.       return (NIL);
  1235.     default:
  1236.       return (errswitch ());
  1237.     }
  1238. }
  1239.  
  1240. LISP
  1241. array_fast_read (int code, LISP table)
  1242. {
  1243.   long j, len, iflag;
  1244.   FILE *f;
  1245.   LISP ptr;
  1246.   f = get_c_file (car (table), (FILE *) NULL);
  1247.   switch (code)
  1248.     {
  1249.     case tc_string:
  1250.       len = get_long (f);
  1251.       ptr = strcons (len, NULL);
  1252.       fread (ptr->storage_as.string.data, len, 1, f);
  1253.       ptr->storage_as.string.data[len] = 0;
  1254.       return (ptr);
  1255.     case tc_byte_array:
  1256.       len = get_long (f);
  1257.       iflag = no_interrupt (1);
  1258.       ptr = newcell (tc_byte_array);
  1259.       ptr->storage_as.string.dim = len;
  1260.       ptr->storage_as.string.data =
  1261.     (char *) must_malloc (len);
  1262.       fread (ptr->storage_as.string.data, len, 1, f);
  1263.       no_interrupt (iflag);
  1264.       return (ptr);
  1265.     case tc_double_array:
  1266.       len = get_long (f);
  1267.       iflag = no_interrupt (1);
  1268.       ptr = newcell (tc_double_array);
  1269.       ptr->storage_as.double_array.dim = len;
  1270.       ptr->storage_as.double_array.data =
  1271.     (double *) must_malloc (len * sizeof (double));
  1272.       fread (ptr->storage_as.double_array.data, sizeof (double), len, f);
  1273.       no_interrupt (iflag);
  1274.       return (ptr);
  1275.     case tc_long_array:
  1276.       len = get_long (f);
  1277.       iflag = no_interrupt (1);
  1278.       ptr = newcell (tc_long_array);
  1279.       ptr->storage_as.long_array.dim = len;
  1280.       ptr->storage_as.long_array.data =
  1281.     (long *) must_malloc (len * sizeof (long));
  1282.       fread (ptr->storage_as.long_array.data, sizeof (long), len, f);
  1283.       no_interrupt (iflag);
  1284.       return (ptr);
  1285.     case tc_lisp_array:
  1286.       len = get_long (f);
  1287.       FLONM (bashnum) = len;
  1288.       ptr = cons_array (bashnum, NIL);
  1289.       for (j = 0; j < len; ++j)
  1290.     ptr->storage_as.lisp_array.data[j] = fast_read (table);
  1291.       return (ptr);
  1292.     default:
  1293.       return (errswitch ());
  1294.     }
  1295. }
  1296.  
  1297. long
  1298. get_c_long (LISP x)
  1299. {
  1300.   if NFLONUMP
  1301.     (x) my_err ("not a number", x);
  1302.   return ((long) FLONM (x));
  1303. }
  1304.  
  1305. double
  1306. get_c_double (LISP x)
  1307. {
  1308.   if NFLONUMP
  1309.     (x) my_err ("not a number", x);
  1310.   return (FLONM (x));
  1311. }
  1312.  
  1313. LISP
  1314. make_list (LISP x, LISP v)
  1315. {
  1316.   long n;
  1317.   LISP l;
  1318.   n = get_c_long (x);
  1319.   l = NIL;
  1320.   while (n > 0)
  1321.     {
  1322.       l = cons (v, l);
  1323.       --n;
  1324.     }
  1325.   return (l);
  1326. }
  1327.  
  1328. LISP
  1329. lfread (LISP size, LISP file)
  1330. {
  1331.   long flag, n, ret, m;
  1332.   char *buffer;
  1333.   LISP s;
  1334.   FILE *f;
  1335.   f = get_c_file (file, stdin);
  1336.   flag = no_interrupt (1);
  1337.   switch (TYPE (size))
  1338.     {
  1339.     case tc_string:
  1340.     case tc_byte_array:
  1341.       s = size;
  1342.       buffer = s->storage_as.string.data;
  1343.       n = s->storage_as.string.dim;
  1344.       m = 0;
  1345.       break;
  1346.     default:
  1347.       n = get_c_long (size);
  1348.       buffer = (char *) must_malloc (n + 1);
  1349.       buffer[n] = 0;
  1350.       m = 1;
  1351.     }
  1352.   ret = fread (buffer, 1, n, f);
  1353.   if (ret == 0)
  1354.     {
  1355.       if (m)
  1356.     free (buffer);
  1357.       no_interrupt (flag);
  1358.       return (NIL);
  1359.     }
  1360.   if (m)
  1361.     {
  1362.       if (ret == n)
  1363.     {
  1364.       s = cons (NIL, NIL);
  1365.       s->type = tc_string;
  1366.       s->storage_as.string.data = buffer;
  1367.       s->storage_as.string.dim = n;
  1368.     }
  1369.       else
  1370.     {
  1371.       s = strcons (ret, NULL);
  1372.       memcpy (s->storage_as.string.data, buffer, ret);
  1373.       free (buffer);
  1374.     }
  1375.       no_interrupt (flag);
  1376.       return (s);
  1377.     }
  1378.   no_interrupt (flag);
  1379.   return (flocons ((double) ret));
  1380. }
  1381.  
  1382. LISP
  1383. lfwrite (LISP string, LISP file)
  1384. {
  1385.   FILE *f;
  1386.   long flag;
  1387.   char *data;
  1388.   long dim, len;
  1389.   f = get_c_file (file, stdout);
  1390.   data = get_c_string_dim (CONSP (string) ? car (string) : string, &dim);
  1391.   len = CONSP (string) ? get_c_long (cadr (string)) : dim;
  1392.   if (len <= 0)
  1393.     return (NIL);
  1394.   if (len > dim)
  1395.     my_err ("write length too long", string);
  1396.   flag = no_interrupt (1);
  1397.   fwrite (data, 1, len, f);
  1398.   no_interrupt (flag);
  1399.   return (NIL);
  1400. }
  1401.  
  1402. LISP
  1403. lfflush (LISP file)
  1404. {
  1405.   FILE *f;
  1406.   long flag;
  1407.   f = get_c_file (file, stdout);
  1408.   flag = no_interrupt (1);
  1409.   fflush (f);
  1410.   no_interrupt (flag);
  1411.   return (NIL);
  1412. }
  1413.  
  1414. LISP
  1415. string_length (LISP string)
  1416. {
  1417.   if NTYPEP
  1418.     (string, tc_string) err_wta_str (string);
  1419.   return (flocons (strlen (string->storage_as.string.data)));
  1420. }
  1421.  
  1422. LISP
  1423. string_dim (LISP string)
  1424. {
  1425.   if NTYPEP
  1426.     (string, tc_string) err_wta_str (string);
  1427.   return (flocons ((double) string->storage_as.string.dim));
  1428. }
  1429.  
  1430. long
  1431. nlength (LISP obj)
  1432. {
  1433.   LISP l;
  1434.   long n;
  1435.   switch TYPE
  1436.     (obj)
  1437.     {
  1438.     case tc_string:
  1439.       return (strlen (obj->storage_as.string.data));
  1440.     case tc_byte_array:
  1441.       return (obj->storage_as.string.dim);
  1442.     case tc_double_array:
  1443.       return (obj->storage_as.double_array.dim);
  1444.     case tc_long_array:
  1445.       return (obj->storage_as.long_array.dim);
  1446.     case tc_lisp_array:
  1447.       return (obj->storage_as.lisp_array.dim);
  1448.     case tc_nil:
  1449.       return (0);
  1450.     case tc_cons:
  1451.       for (l = obj, n = 0; CONSP (l); l = CDR (l), ++n)
  1452.     INTERRUPT_CHECK ();
  1453.       if NNULLP
  1454.     (l) my_err ("improper list to length", obj);
  1455.       return (n);
  1456.     default:
  1457.       my_err ("wta to length", obj);
  1458.       return (0);
  1459.     }
  1460. }
  1461.  
  1462. LISP
  1463. llength (LISP obj)
  1464. {
  1465.   return (flocons (nlength (obj)));
  1466. }
  1467.  
  1468. LISP
  1469. number2string (LISP x, LISP b, LISP w, LISP p)
  1470. {
  1471.   char buffer[1000];
  1472.   double y;
  1473.   int base, width, prec;
  1474.   if NFLONUMP
  1475.     (x) my_err ("wta", x);
  1476.   y = FLONM (x);
  1477.   width = NNULLP (w) ? get_c_long (w) : -1;
  1478.   if (width > 100)
  1479.     my_err ("width too long", w);
  1480.   prec = NNULLP (p) ? get_c_long (p) : -1;
  1481.   if (prec > 100)
  1482.     my_err ("precision too large", p);
  1483.   if (NULLP (b) || EQ (sym_e, b) || EQ (sym_f, b))
  1484.     {
  1485.       if ((width >= 0) && (prec >= 0))
  1486.     sprintf (buffer,
  1487.          NULLP (b) ? "% *.*g" : EQ (sym_e, b) ? "% *.*e" : "% *.*f",
  1488.          width,
  1489.          prec,
  1490.          y);
  1491.       else if (width >= 0)
  1492.     sprintf (buffer,
  1493.          NULLP (b) ? "% *g" : EQ (sym_e, b) ? "% *e" : "% *f",
  1494.          width,
  1495.          y);
  1496.       else if (prec >= 0)
  1497.     sprintf (buffer,
  1498.          NULLP (b) ? "%.*g" : EQ (sym_e, b) ? "%.*e" : "%.*f",
  1499.          prec,
  1500.          y);
  1501.       else
  1502.     sprintf (buffer,
  1503.          NULLP (b) ? "%g" : EQ (sym_e, b) ? "%e" : "%f",
  1504.          y);
  1505.     }
  1506.   else if (((base = get_c_long (b)) == 10) || (base == 8) || (base == 16))
  1507.     {
  1508.       if (width >= 0)
  1509.     sprintf (buffer,
  1510.          (base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX",
  1511.          width,
  1512.          (long) y);
  1513.       else
  1514.     sprintf (buffer,
  1515.          (base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX",
  1516.          (long) y);
  1517.     }
  1518.   else
  1519.     my_err ("number base not handled", b);
  1520.   return (strcons (strlen (buffer), buffer));
  1521. }
  1522.  
  1523. LISP
  1524. string2number (LISP x, LISP b)
  1525. {
  1526.   char *str;
  1527.   long base, value = 0;
  1528.   double result = 0.0;
  1529.   str = get_c_string (x);
  1530.   if NULLP
  1531.     (b)
  1532.       result = atof (str);
  1533.   else if ((base = get_c_long (b)) == 10)
  1534.     {
  1535.       sscanf (str, "%ld", &value);
  1536.       result = (double) value;
  1537.     }
  1538.   else if (base == 8)
  1539.     {
  1540.       sscanf (str, "%lo", &value);
  1541.       result = (double) value;
  1542.     }
  1543.   else if (base == 16)
  1544.     {
  1545.       sscanf (str, "%lx", &value);
  1546.       result = (double) value;
  1547.     }
  1548.   else if ((base >= 1) && (base <= 16))
  1549.     {
  1550.       for (result = 0.0; *str; ++str)
  1551.     if (isdigit (*str))
  1552.       result = result * base + *str - '0';
  1553.     else if (isxdigit (*str))
  1554.       result = result * base + toupper (*str) - 'A' + 10;
  1555.     }
  1556.   else
  1557.     my_err ("number base not handled", b);
  1558.   return (flocons (result));
  1559. }
  1560.  
  1561. LISP
  1562. lstrcmp (LISP s1, LISP s2)
  1563. {
  1564.   return (flocons (strcmp (get_c_string (s1), get_c_string (s2))));
  1565. }
  1566.  
  1567. void
  1568. chk_string (LISP s, char **data, long *dim)
  1569. {
  1570.   if TYPEP
  1571.     (s, tc_string)
  1572.     {
  1573.       *data = s->storage_as.string.data;
  1574.       *dim = s->storage_as.string.dim;
  1575.     }
  1576.   else
  1577.     err_wta_str (s);
  1578. }
  1579.  
  1580. LISP
  1581. lstrcpy (LISP dest, LISP src)
  1582. {
  1583.   long ddim, slen;
  1584.   char *d, *s;
  1585.   chk_string (dest, &d, &ddim);
  1586.   s = get_c_string (src);
  1587.   slen = strlen (s);
  1588.   if (slen > ddim)
  1589.     my_err ("string too long", src);
  1590.   memcpy (d, s, slen);
  1591.   d[slen] = 0;
  1592.   return (NIL);
  1593. }
  1594.  
  1595. LISP
  1596. lstrcat (LISP dest, LISP src)
  1597. {
  1598.   long ddim, dlen, slen;
  1599.   char *d, *s;
  1600.   chk_string (dest, &d, &ddim);
  1601.   s = get_c_string (src);
  1602.   slen = strlen (s);
  1603.   dlen = strlen (d);
  1604.   if ((slen + dlen) > ddim)
  1605.     my_err ("string too long", src);
  1606.   memcpy (&d[dlen], s, slen);
  1607.   d[dlen + slen] = 0;
  1608.   return (NIL);
  1609. }
  1610.  
  1611. LISP
  1612. lstrbreakup (LISP str, LISP lmarker)
  1613. {
  1614.   char *start, *end, *marker;
  1615.   size_t k;
  1616.   LISP result = NIL;
  1617.   start = end = get_c_string (str);
  1618.   marker = get_c_string (lmarker);
  1619.   k = strlen (marker);
  1620.   if (*marker)
  1621.     {
  1622.       while (*end)
  1623.         {
  1624.           if (!(end = strstr (start, marker)))
  1625.             end = &start[strlen (start)];
  1626.           result = cons (strcons (end - start, start), result);
  1627.           start = (*end) ? end + k : end;
  1628.         }
  1629.       return (nreverse (result));
  1630.     }
  1631.   else
  1632.     return (strcons (strlen (start), start));
  1633. }
  1634.  
  1635. LISP
  1636. lstrunbreakup (LISP elems, LISP lmarker)
  1637. {
  1638.   LISP result, l;
  1639.   for (l = elems, result = NIL; NNULLP (l); l = cdr (l))
  1640.     if EQ
  1641.       (l, elems)
  1642.     result = cons (car (l), result);
  1643.     else
  1644.       result = cons (car (l), cons (lmarker, result));
  1645.   return (string_append (nreverse (result)));
  1646. }
  1647.  
  1648. LISP
  1649. stringp (LISP x)
  1650. {
  1651.   return (TYPEP (x, tc_string) ? sym_t : NIL);
  1652. }
  1653.  
  1654. static char *base64_encode_table = "\
  1655. ABCDEFGHIJKLMNOPQRSTUVWXYZ\
  1656. abcdefghijklmnopqrstuvwxyz\
  1657. 0123456789+/=";
  1658.  
  1659. static char *base64_decode_table = NULL;
  1660.  
  1661. static void
  1662. init_base64_table (void)
  1663. {
  1664.   int j;
  1665.   base64_decode_table = (char *) malloc (256);
  1666.   memset (base64_decode_table, -1, 256);
  1667.   for (j = 0; j < 65; ++j)
  1668.     base64_decode_table[(unsigned char) base64_encode_table[j]] = j;
  1669. }
  1670.  
  1671. #define BITMSK(N) ((1 << (N)) - 1)
  1672.  
  1673. #define ITEM1(X)   (X >> 2) & BITMSK(6)
  1674. #define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4))
  1675. #define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2))
  1676. #define ITEM4(X)   X & BITMSK(6)
  1677.  
  1678. LISP
  1679. base64encode (LISP in)
  1680. {
  1681.   char *s, *t = base64_encode_table;
  1682.   unsigned char *p1, *p2;
  1683.   LISP out;
  1684.   long j, m, n, chunks, leftover;
  1685.   s = get_c_string_dim (in, &n);
  1686.   chunks = n / 3;
  1687.   leftover = n % 3;
  1688.   m = (chunks + ((leftover) ? 1 : 0)) * 4;
  1689.   out = strcons (m, NULL);
  1690.   p2 = (unsigned char *) get_c_string (out);
  1691.   for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 3)
  1692.     {
  1693.       *p2++ = t[ITEM1 (p1[0])];
  1694.       *p2++ = t[ITEM2 (p1[0], p1[1])];
  1695.       *p2++ = t[ITEM3 (p1[1], p1[2])];
  1696.       *p2++ = t[ITEM4 (p1[2])];
  1697.     }
  1698.   switch (leftover)
  1699.     {
  1700.     case 0:
  1701.       break;
  1702.     case 1:
  1703.       *p2++ = t[ITEM1 (p1[0])];
  1704.       *p2++ = t[ITEM2 (p1[0], 0)];
  1705.       *p2++ = base64_encode_table[64];
  1706.       *p2++ = base64_encode_table[64];
  1707.       break;
  1708.     case 2:
  1709.       *p2++ = t[ITEM1 (p1[0])];
  1710.       *p2++ = t[ITEM2 (p1[0], p1[1])];
  1711.       *p2++ = t[ITEM3 (p1[1], 0)];
  1712.       *p2++ = base64_encode_table[64];
  1713.       break;
  1714.     default:
  1715.       errswitch ();
  1716.     }
  1717.   return (out);
  1718. }
  1719.  
  1720. LISP
  1721. base64decode (LISP in)
  1722. {
  1723.   char *s, *t = base64_decode_table;
  1724.   LISP out;
  1725.   unsigned char *p1, *p2;
  1726.   long j, m, n, chunks, leftover, item1, item2, item3, item4;
  1727.   s = get_c_string (in);
  1728.   n = strlen (s);
  1729.   if (n == 0)
  1730.     return (strcons (0, NULL));
  1731.   if (n % 4)
  1732.     my_err ("illegal base64 data length", in);
  1733.   if (s[n - 1] == base64_encode_table[64])
  1734.     {
  1735.       if (s[n - 2] == base64_encode_table[64])
  1736.     leftover = 1;
  1737.       else
  1738.     leftover = 2;
  1739.     }
  1740.   else
  1741.     leftover = 0;
  1742.   chunks = (n / 4) - ((leftover) ? 1 : 0);
  1743.   m = (chunks * 3) + leftover;
  1744.   out = strcons (m, NULL);
  1745.   p2 = (unsigned char *) get_c_string (out);
  1746.   for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 4)
  1747.     {
  1748.       if ((item1 = t[p1[0]]) & ~BITMSK (6))
  1749.     return (NIL);
  1750.       if ((item2 = t[p1[1]]) & ~BITMSK (6))
  1751.     return (NIL);
  1752.       if ((item3 = t[p1[2]]) & ~BITMSK (6))
  1753.     return (NIL);
  1754.       if ((item4 = t[p1[3]]) & ~BITMSK (6))
  1755.     return (NIL);
  1756.       *p2++ = (item1 << 2) | (item2 >> 4);
  1757.       *p2++ = (item2 << 4) | (item3 >> 2);
  1758.       *p2++ = (item3 << 6) | item4;
  1759.     }
  1760.   switch (leftover)
  1761.     {
  1762.     case 0:
  1763.       break;
  1764.     case 1:
  1765.       if ((item1 = t[p1[0]]) & ~BITMSK (6))
  1766.     return (NIL);
  1767.       if ((item2 = t[p1[1]]) & ~BITMSK (6))
  1768.     return (NIL);
  1769.       *p2++ = (item1 << 2) | (item2 >> 4);
  1770.       break;
  1771.     case 2:
  1772.       if ((item1 = t[p1[0]]) & ~BITMSK (6))
  1773.     return (NIL);
  1774.       if ((item2 = t[p1[1]]) & ~BITMSK (6))
  1775.     return (NIL);
  1776.       if ((item3 = t[p1[2]]) & ~BITMSK (6))
  1777.     return (NIL);
  1778.       *p2++ = (item1 << 2) | (item2 >> 4);
  1779.       *p2++ = (item2 << 4) | (item3 >> 2);
  1780.       break;
  1781.     default:
  1782.       errswitch ();
  1783.     }
  1784.   return (out);
  1785. }
  1786.  
  1787. LISP
  1788. memq (LISP x, LISP il)
  1789. {
  1790.   LISP l, tmp;
  1791.   for (l = il; CONSP (l); l = CDR (l))
  1792.     {
  1793.       tmp = CAR (l);
  1794.       if EQ
  1795.     (x, tmp) return (l);
  1796.       INTERRUPT_CHECK ();
  1797.     }
  1798.   if EQ
  1799.     (l, NIL) return (NIL);
  1800.   return (my_err ("improper list to memq", il));
  1801. }
  1802.  
  1803. LISP
  1804. member (LISP x, LISP il)
  1805. {
  1806.   LISP l, tmp;
  1807.   for (l = il; CONSP (l); l = CDR (l))
  1808.     {
  1809.       tmp = CAR (l);
  1810.       if NNULLP
  1811.     (equal (x, tmp)) return (l);
  1812.       INTERRUPT_CHECK ();
  1813.     }
  1814.   if EQ
  1815.     (l, NIL) return (NIL);
  1816.   return (my_err ("improper list to member", il));
  1817. }
  1818.  
  1819. LISP
  1820. memv (LISP x, LISP il)
  1821. {
  1822.   LISP l, tmp;
  1823.   for (l = il; CONSP (l); l = CDR (l))
  1824.     {
  1825.       tmp = CAR (l);
  1826.       if NNULLP
  1827.     (eql (x, tmp)) return (l);
  1828.       INTERRUPT_CHECK ();
  1829.     }
  1830.   if EQ
  1831.     (l, NIL) return (NIL);
  1832.   return (my_err ("improper list to memv", il));
  1833. }
  1834.  
  1835.  
  1836. LISP
  1837. nth (LISP x, LISP li)
  1838. {
  1839.   LISP l;
  1840.   long j, n = get_c_long (x);
  1841.   for (j = 0, l = li; (j < n) && CONSP (l); ++j)
  1842.     l = CDR (l);
  1843.   if CONSP
  1844.     (l)
  1845.       return (CAR (l));
  1846.   else
  1847.     return (my_err ("bad arg to nth", x));
  1848. }
  1849.  
  1850. /* these lxxx_default functions are convenient for manipulating
  1851.    command-line argument lists */
  1852.  
  1853. LISP
  1854. lref_default (LISP li, LISP x, LISP fcn)
  1855. {
  1856.   LISP l;
  1857.   long j, n = get_c_long (x);
  1858.   for (j = 0, l = li; (j < n) && CONSP (l); ++j)
  1859.     l = CDR (l);
  1860.   if CONSP
  1861.     (l)
  1862.       return (CAR (l));
  1863.   else if NNULLP
  1864.     (fcn)
  1865.       return (lapply (fcn, NIL));
  1866.   else
  1867.     return (NIL);
  1868. }
  1869.  
  1870. LISP
  1871. larg_default (LISP li, LISP x, LISP dval)
  1872. {
  1873.   LISP l = li, elem;
  1874.   long j = 0, n = get_c_long (x);
  1875.   while NNULLP
  1876.     (l)
  1877.     {
  1878.       elem = car (l);
  1879.       if (TYPEP (elem, tc_string) && strchr ("-:", *get_c_string (elem)))
  1880.     l = cdr (l);
  1881.       else if (j == n)
  1882.     return (elem);
  1883.       else
  1884.     {
  1885.       l = cdr (l);
  1886.       ++j;
  1887.     }
  1888.     }
  1889.   return (dval);
  1890. }
  1891.  
  1892. LISP
  1893. lkey_default (LISP li, LISP key, LISP dval)
  1894. {
  1895.   LISP l = li, elem;
  1896.   char *ckey, *celem;
  1897.   long n;
  1898.   ckey = get_c_string (key);
  1899.   n = strlen (ckey);
  1900.   while NNULLP
  1901.     (l)
  1902.     {
  1903.       elem = car (l);
  1904.       if (TYPEP (elem, tc_string) && (*(celem = get_c_string (elem)) == ':') &&
  1905.       (strncmp (&celem[1], ckey, n) == 0) && (celem[n + 1] == '='))
  1906.     return (strcons (strlen (&celem[n + 2]), &celem[n + 2]));
  1907.       l = cdr (l);
  1908.     }
  1909.   return (dval);
  1910. }
  1911.  
  1912.  
  1913. LISP
  1914. llist (LISP l)
  1915. {
  1916.   return (l);
  1917. }
  1918.  
  1919. LISP
  1920. writes1 (FILE * f, LISP l)
  1921. {
  1922.   LISP v;
  1923.   STACK_CHECK (&v);
  1924.   INTERRUPT_CHECK ();
  1925.   for (v = l; CONSP (v); v = CDR (v))
  1926.     writes1 (f, CAR (v));
  1927.   switch TYPE
  1928.     (v)
  1929.     {
  1930.     case tc_nil:
  1931.       break;
  1932.     case tc_symbol:
  1933.     case tc_string:
  1934.       fput_st (f, get_c_string (v));
  1935.       break;
  1936.     default:
  1937.       lprin1f (v, f);
  1938.       break;
  1939.     }
  1940.   return (NIL);
  1941. }
  1942.  
  1943. LISP
  1944. writes (LISP args)
  1945. {
  1946.   return (writes1 (get_c_file (car (args), stdout), cdr (args)));
  1947. }
  1948.  
  1949. LISP
  1950. last (LISP l)
  1951. {
  1952.   LISP v1, v2;
  1953.   v1 = l;
  1954.   v2 = CONSP (v1) ? CDR (v1) : my_err ("bad arg to last", l);
  1955.   while (CONSP (v2))
  1956.     {
  1957.       INTERRUPT_CHECK ();
  1958.       v1 = v2;
  1959.       v2 = CDR (v2);
  1960.     }
  1961.   return (v1);
  1962. }
  1963.  
  1964. LISP
  1965. butlast (LISP l)
  1966. {
  1967.   INTERRUPT_CHECK ();
  1968.   STACK_CHECK (&l);
  1969.   if NULLP
  1970.     (l) my_err ("list is empty", l);
  1971.   if CONSP (l)
  1972.     {
  1973.       if NULLP (CDR (l))
  1974.     return (NIL);
  1975.       else
  1976.     return (cons (CAR (l), butlast (CDR (l))));
  1977.     }
  1978.   return (my_err ("not a list", l));
  1979. }
  1980.  
  1981. LISP
  1982. nconc (LISP a, LISP b)
  1983. {
  1984.   if NULLP
  1985.     (a)
  1986.       return (b);
  1987.   setcdr (last (a), b);
  1988.   return (a);
  1989. }
  1990.  
  1991. LISP
  1992. funcall1 (LISP fcn, LISP a1)
  1993. {
  1994.   switch TYPE
  1995.     (fcn)
  1996.     {
  1997.     case tc_subr_1:
  1998.       STACK_CHECK (&fcn);
  1999.       INTERRUPT_CHECK ();
  2000.       return (SUBR1 (fcn) (a1));
  2001.     case tc_closure:
  2002.       if TYPEP
  2003.     (fcn->storage_as.closure.code, tc_subr_2)
  2004.     {
  2005.       STACK_CHECK (&fcn);
  2006.       INTERRUPT_CHECK ();
  2007.       return (SUBR2 (fcn->storage_as.closure.code)
  2008.           (fcn->storage_as.closure.env, a1));
  2009.     }
  2010.     default:
  2011.       return (lapply (fcn, cons (a1, NIL)));
  2012.     }
  2013. }
  2014.  
  2015. LISP
  2016. funcall2 (LISP fcn, LISP a1, LISP a2)
  2017. {
  2018.   switch TYPE
  2019.     (fcn)
  2020.     {
  2021.     case tc_subr_2:
  2022.     case tc_subr_2n:
  2023.       STACK_CHECK (&fcn);
  2024.       INTERRUPT_CHECK ();
  2025.       return (SUBR2 (fcn) (a1, a2));
  2026.     default:
  2027.       return (lapply (fcn, cons (a1, cons (a2, NIL))));
  2028.     }
  2029. }
  2030.  
  2031. LISP
  2032. lqsort (LISP l, LISP f, LISP g)
  2033.      /* this is a stupid recursive qsort */
  2034. {
  2035.   int j, n;
  2036.   LISP v, mark, less, notless;
  2037.   for (v = l, n = 0; CONSP (v); v = CDR (v), ++n)
  2038.     INTERRUPT_CHECK ();
  2039.   if NNULLP
  2040.     (v) my_err ("bad list to qsort", l);
  2041.   if (n == 0)
  2042.     return (NIL);
  2043.   j = rand () % n;
  2044.   for (v = l, n = 0; n < j; ++n)
  2045.     v = CDR (v);
  2046.   mark = CAR (v);
  2047.   for (less = NIL, notless = NIL, v = l, n = 0; NNULLP (v); v = CDR (v), ++n)
  2048.     if (j != n)
  2049.       {
  2050.     if NNULLP
  2051.       (funcall2 (f,
  2052.              NULLP (g) ? CAR (v) : funcall1 (g, CAR (v)),
  2053.              NULLP (g) ? mark : funcall1 (g, mark)))
  2054.         less = cons (CAR (v), less);
  2055.     else
  2056.       notless = cons (CAR (v), notless);
  2057.       }
  2058.   return (nconc (lqsort (less, f, g),
  2059.          cons (mark,
  2060.                lqsort (notless, f, g))));
  2061. }
  2062.  
  2063. LISP
  2064. string_lessp (LISP s1, LISP s2)
  2065. {
  2066.   if (strcmp (get_c_string (s1), get_c_string (s2)) < 0)
  2067.     return (sym_t);
  2068.   else
  2069.     return (NIL);
  2070. }
  2071.  
  2072. LISP
  2073. benchmark_funcall1 (LISP ln, LISP f, LISP a1)
  2074. {
  2075.   long j, n;
  2076.   LISP value = NIL;
  2077.   n = get_c_long (ln);
  2078.   for (j = 0; j < n; ++j)
  2079.     value = funcall1 (f, a1);
  2080.   return (value);
  2081. }
  2082.  
  2083. LISP
  2084. benchmark_funcall2 (LISP l)
  2085. {
  2086.   long j, n;
  2087.   LISP ln = car (l);
  2088.   LISP f = car (cdr (l));
  2089.   LISP a1 = car (cdr (cdr (l)));
  2090.   LISP a2 = car (cdr (cdr (cdr (l))));
  2091.   LISP value = NULL;
  2092.   n = get_c_long (ln);
  2093.   for (j = 0; j < n; ++j)
  2094.     value = funcall2 (f, a1, a2);
  2095.   return (value);
  2096. }
  2097.  
  2098. LISP
  2099. benchmark_eval (LISP ln, LISP exp, LISP env)
  2100. {
  2101.   long j, n;
  2102.   LISP value = NIL;
  2103.   n = get_c_long (ln);
  2104.   for (j = 0; j < n; ++j)
  2105.     value = leval (exp, env);
  2106.   return (value);
  2107. }
  2108.  
  2109. LISP
  2110. mapcar1 (LISP fcn, LISP in)
  2111. {
  2112.   LISP res, ptr, l;
  2113.   if NULLP
  2114.     (in) return (NIL);
  2115.   res = ptr = cons (funcall1 (fcn, car (in)), NIL);
  2116.   for (l = cdr (in); CONSP (l); l = CDR (l))
  2117.     ptr = CDR (ptr) = cons (funcall1 (fcn, CAR (l)), CDR (ptr));
  2118.   return (res);
  2119. }
  2120.  
  2121. LISP
  2122. mapcar2 (LISP fcn, LISP in1, LISP in2)
  2123. {
  2124.   LISP res, ptr, l1, l2;
  2125.   if (NULLP (in1) || NULLP (in2))
  2126.     return (NIL);
  2127.   res = ptr = cons (funcall2 (fcn, car (in1), car (in2)), NIL);
  2128.   for (l1 = cdr (in1), l2 = cdr (in2); CONSP (l1) && CONSP (l2); l1 = CDR (l1), l2 = CDR (l2))
  2129.     ptr = CDR (ptr) = cons (funcall2 (fcn, CAR (l1), CAR (l2)), CDR (ptr));
  2130.   return (res);
  2131. }
  2132.  
  2133. LISP
  2134. mapcar (LISP l)
  2135. {
  2136.   LISP fcn = car (l);
  2137.   switch (get_c_long (llength (l)))
  2138.     {
  2139.     case 2:
  2140.       return (mapcar1 (fcn, car (cdr (l))));
  2141.     case 3:
  2142.       return (mapcar2 (fcn, car (cdr (l)), car (cdr (cdr (l)))));
  2143.     default:
  2144.       return (my_err ("mapcar case not handled", l));
  2145.     }
  2146. }
  2147.  
  2148. LISP
  2149. lfmod (LISP x, LISP y)
  2150. {
  2151.   if NFLONUMP
  2152.     (x) my_err ("wta(1st) to fmod", x);
  2153.   if NFLONUMP
  2154.     (y) my_err ("wta(2nd) to fmod", y);
  2155.   return (flocons (fmod (FLONM (x), FLONM (y))));
  2156. }
  2157.  
  2158. LISP
  2159. lsubset (LISP fcn, LISP l)
  2160. {
  2161.   LISP result = NIL, v;
  2162.   for (v = l; CONSP (v); v = CDR (v))
  2163.     if NNULLP
  2164.       (funcall1 (fcn, CAR (v)))
  2165.     result = cons (CAR (v), result);
  2166.   return (nreverse (result));
  2167. }
  2168.  
  2169. LISP
  2170. ass (LISP x, LISP alist, LISP fcn)
  2171. {
  2172.   LISP l, tmp;
  2173.   for (l = alist; CONSP (l); l = CDR (l))
  2174.     {
  2175.       tmp = CAR (l);
  2176.       if (CONSP (tmp) && NNULLP (funcall2 (fcn, CAR (tmp), x)))
  2177.     return (tmp);
  2178.       INTERRUPT_CHECK ();
  2179.     }
  2180.   if EQ
  2181.     (l, NIL) return (NIL);
  2182.   return (my_err ("improper list to ass", alist));
  2183. }
  2184.  
  2185. LISP
  2186. append2 (LISP l1, LISP l2)
  2187. {
  2188.   long n;
  2189.   LISP result = NIL, p1, p2;
  2190.   n = nlength (l1) + nlength (l2);
  2191.   while (n > 0)
  2192.     {
  2193.       result = cons (NIL, result);
  2194.       --n;
  2195.     }
  2196.   for (p1 = result, p2 = l1; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
  2197.     setcar (p1, car (p2));
  2198.   for (p2 = l2; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
  2199.     setcar (p1, car (p2));
  2200.   return (result);
  2201. }
  2202.  
  2203. LISP
  2204. append (LISP l)
  2205. {
  2206.   STACK_CHECK (&l);
  2207.   INTERRUPT_CHECK ();
  2208.   if NULLP
  2209.     (l)
  2210.       return (NIL);
  2211.   else if NULLP
  2212.     (cdr (l))
  2213.       return (car (l));
  2214.   else if NULLP
  2215.     (cddr (l))
  2216.       return (append2 (car (l), cadr (l)));
  2217.   else
  2218.     return (append2 (car (l), append (cdr (l))));
  2219. }
  2220.  
  2221. LISP
  2222. listn (long n,...)
  2223. {
  2224.   LISP result, ptr;
  2225.   long j;
  2226.   va_list args;
  2227.   for (j = 0, result = NIL; j < n; ++j)
  2228.     result = cons (NIL, result);
  2229.   va_start (args, n);
  2230.   for (j = 0, ptr = result; j < n; ptr = cdr (ptr), ++j)
  2231.     setcar (ptr, va_arg (args, LISP));
  2232.   va_end (args);
  2233.   return (result);
  2234. }
  2235.  
  2236.  
  2237. LISP
  2238. fast_load (LISP lfname, LISP noeval)
  2239. {
  2240.   char *fname;
  2241.   LISP stream;
  2242.   LISP result = NIL, form;
  2243.   fname = get_c_string (lfname);
  2244.   if (siod_verbose_level >= 3)
  2245.     {
  2246.       put_st ("fast loading ");
  2247.       put_st (fname);
  2248.       put_st ("\n");
  2249.     }
  2250.   stream = listn (3,
  2251.           fopen_c (fname, "rb"),
  2252.           cons_array (flocons (100), NIL),
  2253.           flocons (0));
  2254.   while (NEQ (stream, form = fast_read (stream)))
  2255.     {
  2256.       if (siod_verbose_level >= 5)
  2257.     lprint (form, NIL);
  2258.       if NULLP
  2259.     (noeval)
  2260.       leval (form, NIL);
  2261.       else
  2262.     result = cons (form, result);
  2263.     }
  2264.   fclose_l (car (stream));
  2265.   if (siod_verbose_level >= 3)
  2266.     put_st ("done.\n");
  2267.   return (nreverse (result));
  2268. }
  2269.  
  2270. static void
  2271. shexstr (char *outstr, void *buff, size_t len)
  2272. {
  2273.   unsigned char *data = buff;
  2274.   size_t j;
  2275.   for (j = 0; j < len; ++j)
  2276.     sprintf (&outstr[j * 2], "%02X", data[j]);
  2277. }
  2278.  
  2279. LISP
  2280. fast_save (LISP fname, LISP forms, LISP nohash, LISP comment)
  2281. {
  2282.   char *cname, msgbuff[100], databuff[50];
  2283.   LISP stream, l;
  2284.   FILE *f;
  2285.   long l_one = 1;
  2286.   double d_one = 1.0;
  2287.   cname = get_c_string (fname);
  2288.   if (siod_verbose_level >= 3)
  2289.     {
  2290.       put_st ("fast saving forms to ");
  2291.       put_st (cname);
  2292.       put_st ("\n");
  2293.     }
  2294.   stream = listn (3,
  2295.           fopen_c (cname, "wb"),
  2296.           NNULLP (nohash) ? NIL : cons_array (flocons (100), NIL),
  2297.           flocons (0));
  2298.   f = get_c_file (car (stream), NULL);
  2299.   if NNULLP
  2300.     (comment)
  2301.       fput_st (f, get_c_string (comment));
  2302.   sprintf (msgbuff, "# Siod Binary Object Save File\n");
  2303.   fput_st (f, msgbuff);
  2304.   sprintf (msgbuff, "# sizeof(long) = %d\n# sizeof(double) = %d\n",
  2305.        (int) sizeof (long), (int) sizeof (double));
  2306.   fput_st (f, msgbuff);
  2307.   shexstr (databuff, &l_one, sizeof (l_one));
  2308.   sprintf (msgbuff, "# 1 = %s\n", databuff);
  2309.   fput_st (f, msgbuff);
  2310.   shexstr (databuff, &d_one, sizeof (d_one));
  2311.   sprintf (msgbuff, "# 1.0 = %s\n", databuff);
  2312.   fput_st (f, msgbuff);
  2313.   for (l = forms; NNULLP (l); l = cdr (l))
  2314.     fast_print (car (l), stream);
  2315.   fclose_l (car (stream));
  2316.   if (siod_verbose_level >= 3)
  2317.     put_st ("done.\n");
  2318.   return (NIL);
  2319. }
  2320.  
  2321. void
  2322. swrite1 (LISP stream, LISP data)
  2323. {
  2324.   FILE *f = get_c_file (stream, stdout);
  2325.   switch TYPE
  2326.     (data)
  2327.     {
  2328.     case tc_symbol:
  2329.     case tc_string:
  2330.       fput_st (f, get_c_string (data));
  2331.       break;
  2332.     default:
  2333.       lprin1f (data, f);
  2334.       break;
  2335.     }
  2336. }
  2337.  
  2338. LISP
  2339. swrite (LISP stream, LISP table, LISP data)
  2340. {
  2341.   LISP value, key;
  2342.   long j, k, m, n;
  2343.   switch (TYPE (data))
  2344.     {
  2345.     case tc_symbol:
  2346.       value = href (table, data);
  2347.       if CONSP
  2348.     (value)
  2349.     {
  2350.       swrite1 (stream, CAR (value));
  2351.       if NNULLP
  2352.         (CDR (value))
  2353.           hset (table, data, CDR (value));
  2354.     }
  2355.       else
  2356.     swrite1 (stream, value);
  2357.       break;
  2358.     case tc_lisp_array:
  2359.       n = data->storage_as.lisp_array.dim;
  2360.       if (n < 1)
  2361.     my_err ("no object repeat count", data);
  2362.       key = data->storage_as.lisp_array.data[0];
  2363.       if NULLP
  2364.     (value = href (table, key))
  2365.       value = key;
  2366.       else if CONSP
  2367.     (value)
  2368.     {
  2369.       if NNULLP
  2370.         (CDR (value))
  2371.           hset (table, key, CDR (value));
  2372.       value = CAR (value);
  2373.     }
  2374.       m = get_c_long (value);
  2375.       for (k = 0; k < m; ++k)
  2376.     for (j = 1; j < n; ++j)
  2377.       swrite (stream, table, data->storage_as.lisp_array.data[j]);
  2378.       break;
  2379.     case tc_cons:
  2380.       /* this should be handled similar to the array case */
  2381.     default:
  2382.       swrite1 (stream, data);
  2383.     }
  2384.   return (NIL);
  2385. }
  2386.  
  2387. LISP
  2388. lpow (LISP x, LISP y)
  2389. {
  2390.   if NFLONUMP
  2391.     (x) my_err ("wta(1st) to pow", x);
  2392.   if NFLONUMP
  2393.     (y) my_err ("wta(2nd) to pow", y);
  2394.   return (flocons (pow (FLONM (x), FLONM (y))));
  2395. }
  2396.  
  2397. LISP
  2398. lexp (LISP x)
  2399. {
  2400.   return (flocons (exp (get_c_double (x))));
  2401. }
  2402.  
  2403. LISP
  2404. llog (LISP x)
  2405. {
  2406.   return (flocons (log (get_c_double (x))));
  2407. }
  2408.  
  2409. LISP
  2410. lsin (LISP x)
  2411. {
  2412.   return (flocons (sin (get_c_double (x))));
  2413. }
  2414.  
  2415. LISP
  2416. lcos (LISP x)
  2417. {
  2418.   return (flocons (cos (get_c_double (x))));
  2419. }
  2420.  
  2421. LISP
  2422. ltan (LISP x)
  2423. {
  2424.   return (flocons (tan (get_c_double (x))));
  2425. }
  2426.  
  2427. LISP
  2428. lasin (LISP x)
  2429. {
  2430.   return (flocons (asin (get_c_double (x))));
  2431. }
  2432.  
  2433. LISP
  2434. lacos (LISP x)
  2435. {
  2436.   return (flocons (acos (get_c_double (x))));
  2437. }
  2438.  
  2439. LISP
  2440. latan (LISP x)
  2441. {
  2442.   return (flocons (atan (get_c_double (x))));
  2443. }
  2444.  
  2445. LISP
  2446. latan2 (LISP x, LISP y)
  2447. {
  2448.   return (flocons (atan2 (get_c_double (x), get_c_double (y))));
  2449. }
  2450.  
  2451. LISP
  2452. hexstr (LISP a)
  2453. {
  2454.   unsigned char *in;
  2455.   char *out;
  2456.   LISP result;
  2457.   long j, dim;
  2458.   in = (unsigned char *) get_c_string_dim (a, &dim);
  2459.   result = strcons (dim * 2, NULL);
  2460.   for (out = get_c_string (result), j = 0; j < dim; ++j, out += 2)
  2461.     sprintf (out, "%02x", in[j]);
  2462.   return (result);
  2463. }
  2464.  
  2465. static int
  2466. xdigitvalue (int c)
  2467. {
  2468.   if (isdigit (c))
  2469.       return (c - '0');
  2470.   if (isxdigit (c))
  2471.       return (toupper (c) - 'A' + 10);
  2472.   return (0);
  2473. }
  2474.  
  2475. LISP
  2476. hexstr2bytes (LISP a)
  2477. {
  2478.   char *in;
  2479.   unsigned char *out;
  2480.   LISP result;
  2481.   long j, dim;
  2482.   in = get_c_string (a);
  2483.   dim = strlen (in) / 2;
  2484.   result = arcons (tc_byte_array, dim, 0);
  2485.   out = (unsigned char *) result->storage_as.string.data;
  2486.   for (j = 0; j < dim; ++j)
  2487.     out[j] = xdigitvalue (in[j * 2]) * 16 + xdigitvalue (in[j * 2 + 1]);
  2488.   return (result);
  2489. }
  2490.  
  2491. LISP
  2492. getprop (LISP plist, LISP key)
  2493. {
  2494.   LISP l;
  2495.   for (l = cdr (plist); NNULLP (l); l = cddr (l))
  2496.     if EQ
  2497.       (car (l), key)
  2498.     return (cadr (l));
  2499.     else
  2500.       INTERRUPT_CHECK ();
  2501.   return (NIL);
  2502. }
  2503.  
  2504. LISP
  2505. setprop (LISP plist, LISP key, LISP value)
  2506. {
  2507.   my_err ("not implemented", NIL);
  2508.   return (NIL);
  2509. }
  2510.  
  2511. LISP
  2512. putprop (LISP plist, LISP value, LISP key)
  2513. {
  2514.   return (setprop (plist, key, value));
  2515. }
  2516.  
  2517. LISP
  2518. ltypeof (LISP obj)
  2519. {
  2520.   long x;
  2521.   x = TYPE (obj);
  2522.   switch (x)
  2523.     {
  2524.     case tc_nil:
  2525.       return (cintern ("tc_nil"));
  2526.     case tc_cons:
  2527.       return (cintern ("tc_cons"));
  2528.     case tc_flonum:
  2529.       return (cintern ("tc_flonum"));
  2530.     case tc_symbol:
  2531.       return (cintern ("tc_symbol"));
  2532.     case tc_subr_0:
  2533.       return (cintern ("tc_subr_0"));
  2534.     case tc_subr_1:
  2535.       return (cintern ("tc_subr_1"));
  2536.     case tc_subr_2:
  2537.       return (cintern ("tc_subr_2"));
  2538.     case tc_subr_2n:
  2539.       return (cintern ("tc_subr_2n"));
  2540.     case tc_subr_3:
  2541.       return (cintern ("tc_subr_3"));
  2542.     case tc_subr_4:
  2543.       return (cintern ("tc_subr_4"));
  2544.     case tc_subr_5:
  2545.       return (cintern ("tc_subr_5"));
  2546.     case tc_lsubr:
  2547.       return (cintern ("tc_lsubr"));
  2548.     case tc_fsubr:
  2549.       return (cintern ("tc_fsubr"));
  2550.     case tc_msubr:
  2551.       return (cintern ("tc_msubr"));
  2552.     case tc_closure:
  2553.       return (cintern ("tc_closure"));
  2554.     case tc_free_cell:
  2555.       return (cintern ("tc_free_cell"));
  2556.     case tc_string:
  2557.       return (cintern ("tc_string"));
  2558.     case tc_byte_array:
  2559.       return (cintern ("tc_byte_array"));
  2560.     case tc_double_array:
  2561.       return (cintern ("tc_double_array"));
  2562.     case tc_long_array:
  2563.       return (cintern ("tc_long_array"));
  2564.     case tc_lisp_array:
  2565.       return (cintern ("tc_lisp_array"));
  2566.     case tc_c_file:
  2567.       return (cintern ("tc_c_file"));
  2568.     default:
  2569.       return (flocons (x));
  2570.     }
  2571. }
  2572.  
  2573. LISP
  2574. caaar (LISP x)
  2575. {
  2576.   return (car (car (car (x))));
  2577. }
  2578.  
  2579. LISP
  2580. caadr (LISP x)
  2581. {
  2582.   return (car (car (cdr (x))));
  2583. }
  2584.  
  2585. LISP
  2586. cadar (LISP x)
  2587. {
  2588.   return (car (cdr (car (x))));
  2589. }
  2590.  
  2591. LISP
  2592. caddr (LISP x)
  2593. {
  2594.   return (car (cdr (cdr (x))));
  2595. }
  2596.  
  2597. LISP
  2598. cdaar (LISP x)
  2599. {
  2600.   return (cdr (car (car (x))));
  2601. }
  2602.  
  2603. LISP
  2604. cdadr (LISP x)
  2605. {
  2606.   return (cdr (car (cdr (x))));
  2607. }
  2608.  
  2609. LISP
  2610. cddar (LISP x)
  2611. {
  2612.   return (cdr (cdr (car (x))));
  2613. }
  2614.  
  2615. LISP
  2616. cdddr (LISP x)
  2617. {
  2618.   return (cdr (cdr (cdr (x))));
  2619. }
  2620.  
  2621. LISP
  2622. ash (LISP value, LISP n)
  2623. {
  2624.   long m, k;
  2625.   m = get_c_long (value);
  2626.   k = get_c_long (n);
  2627.   if (k > 0)
  2628.     m = m << k;
  2629.   else
  2630.     m = m >> (-k);
  2631.   return (flocons (m));
  2632. }
  2633.  
  2634. LISP
  2635. bitand (LISP a, LISP b)
  2636. {
  2637.   return (flocons (get_c_long (a) & get_c_long (b)));
  2638. }
  2639.  
  2640. LISP
  2641. bitor (LISP a, LISP b)
  2642. {
  2643.   return (flocons (get_c_long (a) | get_c_long (b)));
  2644. }
  2645.  
  2646. LISP
  2647. bitxor (LISP a, LISP b)
  2648. {
  2649.   return (flocons (get_c_long (a) ^ get_c_long (b)));
  2650. }
  2651.  
  2652. LISP
  2653. bitnot (LISP a)
  2654. {
  2655.   return (flocons (~get_c_long (a)));
  2656. }
  2657.  
  2658. LISP
  2659. leval_prog1 (LISP args, LISP env)
  2660. {
  2661.   LISP retval, l;
  2662.   retval = leval (car (args), env);
  2663.   for (l = cdr (args); NNULLP (l); l = cdr (l))
  2664.     leval (car (l), env);
  2665.   return (retval);
  2666. }
  2667.  
  2668. LISP
  2669. leval_cond (LISP * pform, LISP * penv)
  2670. {
  2671.   LISP args, env, clause, value, next;
  2672.   args = cdr (*pform);
  2673.   env = *penv;
  2674.   if NULLP
  2675.     (args)
  2676.     {
  2677.       *pform = NIL;
  2678.       return (NIL);
  2679.     }
  2680.   next = cdr (args);
  2681.   while NNULLP
  2682.     (next)
  2683.     {
  2684.       clause = car (args);
  2685.       value = leval (car (clause), env);
  2686.       if NNULLP
  2687.     (value)
  2688.     {
  2689.       clause = cdr (clause);
  2690.       if NULLP
  2691.         (clause)
  2692.         {
  2693.           *pform = value;
  2694.           return (NIL);
  2695.         }
  2696.       else
  2697.         {
  2698.           next = cdr (clause);
  2699.           while (NNULLP (next))
  2700.         {
  2701.           leval (car (clause), env);
  2702.           clause = next;
  2703.           next = cdr (next);
  2704.         }
  2705.           *pform = car (clause);
  2706.           return (sym_t);
  2707.         }
  2708.     }
  2709.       args = next;
  2710.       next = cdr (next);
  2711.     }
  2712.   clause = car (args);
  2713.   next = cdr (clause);
  2714.   if NULLP
  2715.     (next)
  2716.     {
  2717.       *pform = car (clause);
  2718.       return (sym_t);
  2719.     }
  2720.   value = leval (car (clause), env);
  2721.   if NULLP
  2722.     (value)
  2723.     {
  2724.       *pform = NIL;
  2725.       return (NIL);
  2726.     }
  2727.   clause = next;
  2728.   next = cdr (next);
  2729.   while (NNULLP (next))
  2730.     {
  2731.       leval (car (clause), env);
  2732.       clause = next;
  2733.       next = cdr (next);
  2734.     }
  2735.   *pform = car (clause);
  2736.   return (sym_t);
  2737. }
  2738.  
  2739. LISP
  2740. lstrspn (LISP str1, LISP str2)
  2741. {
  2742.   return (flocons (strspn (get_c_string (str1), get_c_string (str2))));
  2743. }
  2744.  
  2745. LISP
  2746. lstrcspn (LISP str1, LISP str2)
  2747. {
  2748.   return (flocons (strcspn (get_c_string (str1), get_c_string (str2))));
  2749. }
  2750.  
  2751. LISP
  2752. substring_equal (LISP str1, LISP str2, LISP start, LISP end)
  2753. {
  2754.   char *cstr1, *cstr2;
  2755.   long len1, n, s, e;
  2756.   cstr1 = get_c_string_dim (str1, &len1);
  2757.   cstr2 = get_c_string_dim (str2, &n);
  2758.   s = NULLP (start) ? 0 : get_c_long (start);
  2759.   e = NULLP (end) ? n : get_c_long (end);
  2760.   if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
  2761.     return (NIL);
  2762.   return ((memcmp (cstr1, &cstr2[s], e - s) == 0) ? a_true_value () : NIL);
  2763. }
  2764.  
  2765. LISP
  2766. set_eval_history (LISP len, LISP circ)
  2767. {
  2768.   LISP data;
  2769.   data = NULLP (len) ? len : make_list (len, NIL);
  2770.   if NNULLP
  2771.     (circ)
  2772.       data = nconc (data, data);
  2773.   setvar (cintern ("*eval-history-ptr*"), data, NIL);
  2774.   setvar (cintern ("*eval-history*"), data, NIL);
  2775.   return (len);
  2776. }
  2777.  
  2778. static LISP
  2779. parser_fasl (LISP ignore)
  2780. {
  2781.   return (closure (listn (3,
  2782.               NIL,
  2783.               cons_array (flocons (100), NIL),
  2784.               flocons (0)),
  2785.            leval (cintern ("parser_fasl_hook"), NIL)));
  2786. }
  2787.  
  2788. static LISP
  2789. parser_fasl_hook (LISP env, LISP f)
  2790. {
  2791.   LISP result;
  2792.   setcar (env, f);
  2793.   result = fast_read (env);
  2794.   if EQ
  2795.     (result, env)
  2796.       return (get_eof_val ());
  2797.   else
  2798.     return (result);
  2799. }
  2800.  
  2801. void
  2802. init_subrs_a (void)
  2803. {
  2804.   init_subr_2 ("aref", aref1);
  2805.   init_subr_3 ("aset", aset1);
  2806.   init_lsubr ("string-append", string_append);
  2807.   init_lsubr ("bytes-append", bytes_append);
  2808.   init_subr_1 ("string-length", string_length);
  2809.   init_subr_1 ("string-dimension", string_dim);
  2810.   init_subr_1 ("read-from-string", read_from_string);
  2811.   init_subr_3 ("print-to-string", print_to_string);
  2812.   init_subr_2 ("cons-array", cons_array);
  2813.   init_subr_2 ("sxhash", sxhash);
  2814.   init_subr_2 ("equal?", equal);
  2815.   init_subr_2 ("href", href);
  2816.   init_subr_3 ("hset", hset);
  2817.   init_subr_2 ("assoc", assoc);
  2818.   init_subr_2 ("assv", assv);
  2819.   init_subr_1 ("fast-read", fast_read);
  2820.   init_subr_2 ("fast-print", fast_print);
  2821.   init_subr_2 ("make-list", make_list);
  2822.   init_subr_2 ("fread", lfread);
  2823.   init_subr_2 ("fwrite", lfwrite);
  2824.   init_subr_1 ("fflush", lfflush);
  2825.   init_subr_1 ("length", llength);
  2826.   init_subr_4 ("number->string", number2string);
  2827.   init_subr_2 ("string->number", string2number);
  2828.   init_subr_3 ("substring", substring);
  2829.   init_subr_2 ("string-search", string_search);
  2830.   init_subr_1 ("string-trim", string_trim);
  2831.   init_subr_1 ("string-trim-left", string_trim_left);
  2832.   init_subr_1 ("string-trim-right", string_trim_right);
  2833.   init_subr_1 ("string-upcase", string_upcase);
  2834.   init_subr_1 ("string-downcase", string_downcase);
  2835.   init_subr_2 ("strcmp", lstrcmp);
  2836.   init_subr_2 ("strcat", lstrcat);
  2837.   init_subr_2 ("strcpy", lstrcpy);
  2838.   init_subr_2 ("strbreakup", lstrbreakup);
  2839.   init_subr_2 ("unbreakupstr", lstrunbreakup);
  2840.   init_subr_1 ("string?", stringp);
  2841.   gc_protect_sym (&sym_e, "e");
  2842.   gc_protect_sym (&sym_f, "f");
  2843.   gc_protect_sym (&sym_plists, "*plists*");
  2844.   setvar (sym_plists, arcons (tc_lisp_array, 100, 1), NIL);
  2845.   init_subr_3 ("lref-default", lref_default);
  2846.   init_subr_3 ("larg-default", larg_default);
  2847.   init_subr_3 ("lkey-default", lkey_default);
  2848.   init_lsubr ("list", llist);
  2849.   init_lsubr ("writes", writes);
  2850.   init_subr_3 ("qsort", lqsort);
  2851.   init_subr_2 ("string-lessp", string_lessp);
  2852.   init_lsubr ("mapcar", mapcar);
  2853.   init_subr_3 ("mapcar2", mapcar2);
  2854.   init_subr_2 ("mapcar1", mapcar1);
  2855.   init_subr_3 ("benchmark-funcall1", benchmark_funcall1);
  2856.   init_lsubr ("benchmark-funcall2", benchmark_funcall2);
  2857.   init_subr_3 ("benchmark-eval", benchmark_eval);
  2858.   init_subr_2 ("fmod", lfmod);
  2859.   init_subr_2 ("subset", lsubset);
  2860.   init_subr_1 ("base64encode", base64encode);
  2861.   init_subr_1 ("base64decode", base64decode);
  2862.   init_subr_3 ("ass", ass);
  2863.   init_subr_2 ("append2", append2);
  2864.   init_lsubr ("append", append);
  2865.   init_subr_4 ("fast-save", fast_save);
  2866.   init_subr_2 ("fast-load", fast_load);
  2867.   init_subr_3 ("swrite", swrite);
  2868.   init_subr_2 ("pow", lpow);
  2869.   init_subr_1 ("exp", lexp);
  2870.   init_subr_1 ("log", llog);
  2871.   init_subr_1 ("sin", lsin);
  2872.   init_subr_1 ("cos", lcos);
  2873.   init_subr_1 ("tan", ltan);
  2874.   init_subr_1 ("asin", lasin);
  2875.   init_subr_1 ("acos", lacos);
  2876.   init_subr_1 ("atan", latan);
  2877.   init_subr_2 ("atan2", latan2);
  2878.   init_subr_1 ("typeof", ltypeof);
  2879.   init_subr_1 ("caaar", caaar);
  2880.   init_subr_1 ("caadr", caadr);
  2881.   init_subr_1 ("cadar", cadar);
  2882.   init_subr_1 ("caddr", caddr);
  2883.   init_subr_1 ("cdaar", cdaar);
  2884.   init_subr_1 ("cdadr", cdadr);
  2885.   init_subr_1 ("cddar", cddar);
  2886.   init_subr_1 ("cdddr", cdddr);
  2887.   setvar (cintern ("*pi*"), flocons (atan (1.0) * 4), NIL);
  2888.   init_base64_table ();
  2889.   init_subr_1 ("array->hexstr", hexstr);
  2890.   init_subr_1 ("hexstr->bytes", hexstr2bytes);
  2891.   init_subr_3 ("ass", ass);
  2892.   init_subr_2 ("bit-and", bitand);
  2893.   init_subr_2 ("bit-or", bitor);
  2894.   init_subr_2 ("bit-xor", bitxor);
  2895.   init_subr_1 ("bit-not", bitnot);
  2896.   init_msubr ("cond", leval_cond);
  2897.   init_fsubr ("prog1", leval_prog1);
  2898.   init_subr_2 ("strspn", lstrspn);
  2899.   init_subr_2 ("strcspn", lstrcspn);
  2900.   init_subr_4 ("substring-equal?", substring_equal);
  2901.   init_subr_1 ("butlast", butlast);
  2902.   init_subr_2 ("ash", ash);
  2903.   init_subr_2 ("get", getprop);
  2904.   init_subr_3 ("setprop", setprop);
  2905.   init_subr_3 ("putprop", putprop);
  2906.   init_subr_1 ("last", last);
  2907.   init_subr_2 ("memq", memq);
  2908.   init_subr_2 ("memv", memv);
  2909.   init_subr_2 ("member", member);
  2910.   init_subr_2 ("nth", nth);
  2911.   init_subr_2 ("nconc", nconc);
  2912.   init_subr_2 ("set-eval-history", set_eval_history);
  2913.   init_subr_1 ("parser_fasl", parser_fasl);
  2914.   setvar (cintern ("*parser_fasl.scm-loaded*"), a_true_value (), NIL);
  2915.   init_subr_2 ("parser_fasl_hook", parser_fasl_hook);
  2916.   init_sliba_version ();
  2917. }
  2918.